SUBROUTINE p(k,x,val)

!-------------------------------------------------------------
!
!  Compute the values of P from the Legendre polynomials
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: k
REAL*8, INTENT(IN) :: x
REAL*8, INTENT(OUT) :: val

IF (k == 0) THEN
   val = 1.0
ELSE IF (k == 1) THEN
   val = x
ELSE IF (k == 2) THEN
   val = 1.5*(x**2) - 0.5
ELSE IF (k == 3) THEN
   val = 2.5*(x**3) - 1.5*x
ELSE IF (k == 4) THEN
   val = (35.0*(x**4) - 30.0*(x**2) + 3.0)/8.0
ELSE IF (k == 5) THEN
   val = (63.0*(x**5) - 70.0*(x**3) + 15.0*x)/8.0
ELSE IF (k == 6) THEN
   val = (231.0*(x**6) - 315.0*(x**4) + 105.0*(x**2) - 5.0)/16.0
ELSE IF (k == 7) THEN
   val = (429.0*(x**7) - 693.0*(x**5) + 315.0*(x**3) - 35.0*x)/16.0
ELSE IF (k == 8) THEN
   val = x*(((26.8125*x*x-43.3125)*x*x+19.6875)*x*x-2.1875)
ELSE
   warn = warn + 1
   WRITE (8,'(//,1X,A)') "WARNING: outside of range that Legendre is currently programmed in this p.f90 version"
   val = 0.0
END IF

RETURN
END SUBROUTINE p


program main
    use iso_fortran_env, only: real32
    use julia_set_m, only: generate_julia_set, draw_julia_set
    use save_julia_set_image, only: julia_set_image
    implicit none
    integer, parameter :: width = 80
    integer, parameter :: height = 50
    integer, dimension(height, width) :: julia_set
    complex(real32), parameter :: c = (-0.835, -0.2321)

    call generate_julia_set(julia_set, -1.5, 1.5, -1., 1., c, 1000)

    call draw_julia_set(julia_set)

    call julia_set_image(julia_set)

end program main


module cosine_transform_routines

    use auxiliary_routines, only: &
        get_1d_saved_workspace_length, &
        fft_error_handler, &
        fft_consistent

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use real_transform_routines, only: &
        rfft1i, &
        rfft1f, &
        rfftmi, &
        rfftmf

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: cost1i, cost1b, cost1f, costmi, costmb, costmf

    !---------------------------------------------------------------------------------
    ! Variables confined to the module
    !---------------------------------------------------------------------------------
    real (wp), parameter :: ZERO = 0.0_wp
    real (wp), parameter :: HALF = 0.5_wp
    real (wp), parameter :: ONE = 1.0_wp
    real (wp), parameter :: TWO = 2.0_wp
    !---------------------------------------------------------------------------------

contains

    subroutine cost1i(n, wsave, lensav, ier)
        !
        ! cost1i: initialization for cost1b and cost1f.
        !
        !  purpose:
        !
        !  cost1i initializes array wsave for use in its companion routines
        !  cost1f and cost1b.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n-1 is a product
        !  of small primes.
        !
        !  integer lensav, dimension of wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors of
        !  n and also containing certain trigonometric values which will be used in
        !  routines cost1b or cost1f.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) lensav
        real (wp) dt
        real (wp) fk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lnsv
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: PI = acos(-ONE)
        real (wp) wsave(lensav)
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('cost1i', 3)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n > 3) then

            nm1 = n-1
            np1 = n+1
            ns2 = n/2
            dt = pi/ nm1
            fk = ZERO

            do k=2,ns2
                kc = np1-k
                fk = fk + ONE
                wsave(k) = TWO * sin(fk*dt)
                wsave(kc) = TWO * cos(fk*dt)
            end do

            lnsv = nm1 + int(log(real(nm1, kind=wp) )/log(TWO)) +4

            call rfft1i(nm1, wsave(n+1), lnsv, local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('cost1i',-5)
            end if
        end if

    end subroutine cost1i

    subroutine cost1b(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! cost1b: real backward cosine transform, 1d.
        !
        !  purpose:
        !
        !  cost1b computes the one-dimensional fourier transform of an even
        !  sequence within a real array.  this transform is referred to as
        !  the backward transform or fourier synthesis, transforming the sequence
        !  from spectral to physical space.
        !
        !  this transform is normalized since a call to cost1b followed
        !  by a call to cost1f (or vice-versa) reproduces the original array
        !  within roundoff error.
        !
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n-1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), containing the sequence to
        !   be transformed.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to cost1i before the first call to routine cost1f
        !  or cost1b for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to cost1f and cost1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least n-1.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) lenx
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('cost1b', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('cost1b', 8)
            return
        else if (lenwrk < n-1) then
            ier = 3
            call fft_error_handler('cost1b', 10)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n /= 1) then

            call costb1(n,inc,x,wsave,work,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('cost1b',-5)
            end if
        end if

    end subroutine cost1b

    subroutine cost1f(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        ! cost1f: 64-bit float precision forward cosine transform, 1d.
        !
        !  purpose:
        !
        !  cost1f computes the one-dimensional fourier transform of an even
        !  sequence within a real array.  this transform is referred to as the
        !  forward transform or fourier analysis, transforming the sequence
        !  from  physical to spectral space.
        !
        !  this transform is normalized since a call to cost1f followed by a call
        !  to cost1b (or vice-versa) reproduces the original array within
        !  roundoff error.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n-1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), containing the sequence to
        !  be transformed.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to cost1i before the first call to routine cost1f
        !  or cost1b for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to cost1f and cost1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least n-1.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !

        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk

        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) lenx
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('cost1f', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('cost1f', 8)
            return
        else if (lenwrk < n-1) then
            ier = 3
            call fft_error_handler('cost1f', 10)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n /= 1) then

            call costf1(n,inc,x,wsave,work,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('cost1f',-5)
            end if
        end if

    end subroutine cost1f

    subroutine costb1(n, inc, x, wsave, work, ier)

        integer (ip) inc
        real (wp) dsum
        real (wp) fnm1s2
        real (wp) fnm1s4
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) modn
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) x1h
        real (wp) x1p3
        real (wp) x2
        real (wp) xi

        ier = 0

        nm1 = n-1
        np1 = n+1
        ns2 = n/2

        if (n < 2) then
            return
        else if (n == 2) then
            x1h = x(1,1)+x(1,2)
            x(1,2) = x(1,1)-x(1,2)
            x(1,1) = x1h
        else
            if (3 >= n) then
                x1p3 = x(1,1)+x(1,3)
                x2 = x(1,2)
                x(1,2) = x(1,1)-x(1,3)
                x(1,1) = x1p3+x2
                x(1,3) = x1p3-x2
            else
                x(1,1) = x(1,1)+x(1,1)
                x(1,n) = x(1,n)+x(1,n)
                dsum = x(1,1)-x(1,n)
                x(1,1) = x(1,1)+x(1,n)

                do k=2,ns2
                    kc = np1-k
                    t1 = x(1,k)+x(1,kc)
                    t2 = x(1,k)-x(1,kc)
                    dsum = dsum+wsave(kc)*t2
                    t2 = wsave(k)*t2
                    x(1,k) = t1-t2
                    x(1,kc) = t1+t2
                end do

                modn = mod(n,2)

                if (modn /= 0) then
                    x(1,ns2+1) = TWO * x(1,ns2+1)
                end if

                lenx = inc*(nm1-1) + 1
                lnsv = nm1 + int(log(real(nm1, kind=wp))/log(TWO), kind=ip) + 4
                lnwk = nm1

                call rfft1f(nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,local_error_flag)

                if (local_error_flag /= 0) then
                    ier = 20
                    call fft_error_handler('costb1',-5)
                    return
                end if

                fnm1s2 = real(nm1, kind=wp)/2
                dsum = HALF * dsum
                x(1,1) = fnm1s2*x(1,1)

                if (mod(nm1,2) == 0) then
                    x(1,nm1) = TWO * x(1,nm1)
                end if

                fnm1s4 = real(nm1, kind=wp)/4

                do i=3,n,2
                    xi = fnm1s4*x(1,i)
                    x(1,i) = fnm1s4*x(1,i-1)
                    x(1,i-1) = dsum
                    dsum = dsum+xi
                end do

                if (modn == 0) then
                    x(1,n) = dsum
                end if
            end if
        end if

    end subroutine costb1

    subroutine costf1(n, inc, x, wsave, work, ier)

        integer (ip) inc
        real (wp) dsum
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) modn
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp) snm1
        real (wp) t1
        real (wp) t2
        real (wp) tx2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) x1h
        real (wp) x1p3
        real (wp) xi

        ier = 0

        nm1 = n-1
        np1 = n+1
        ns2 = n/2

        if (n < 2) then
            return
        else if (n == 2) then
            x1h = x(1,1)+x(1,2)
            x(1,2) = HALF * (x(1,1)-x(1,2))
            x(1,1) = HALF * x1h
        else
            if (3 >= n) then
                x1p3 = x(1,1)+x(1,3)
                tx2 = x(1,2)+x(1,2)
                x(1,2) = HALF * (x(1,1)-x(1,3))
                x(1,1) = 0.25_wp *(x1p3+tx2)
                x(1,3) = 0.25_wp *(x1p3-tx2)
            else
                dsum = x(1,1)-x(1,n)
                x(1,1) = x(1,1)+x(1,n)
                do k=2,ns2
                    kc = np1-k
                    t1 = x(1,k)+x(1,kc)
                    t2 = x(1,k)-x(1,kc)
                    dsum = dsum+wsave(kc)*t2
                    t2 = wsave(k)*t2
                    x(1,k) = t1-t2
                    x(1,kc) = t1+t2
                end do

                modn = mod(n,2)

                if (modn /= 0) then
                    x(1,ns2+1) = x(1,ns2+1)+x(1,ns2+1)
                end if

                ! Set workspace index pointers
                lenx = inc*(nm1-1)  + 1
                lnsv = nm1 + int(log(real(nm1, kind=wp) )/log(TWO)) + 4
                lnwk = nm1

                call rfft1f(nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,local_error_flag)

                if (local_error_flag /= 0) then
                    ier = 20
                    call fft_error_handler('costf1',-5)
                    return
                end if

                snm1 = ONE /nm1
                dsum = snm1*dsum

                if (mod(nm1,2) == 0) then
                    x(1,nm1) = x(1,nm1)+x(1,nm1)
                end if

                do i=3,n,2
                    xi = HALF * x(1,i)
                    x(1,i) = HALF * x(1,i-1)
                    x(1,i-1) = dsum
                    dsum = dsum+xi
                end do

                if (modn == 0) then
                    x(1,n) = dsum
                end if

                x(1,1) = HALF * x(1,1)
                x(1,n) = HALF * x(1,n)
            end if
        end if

    end subroutine costf1

    subroutine costmi(n, wsave, lensav, ier)
        !
        ! costmi: initialization for costmb and costmf.
        !
        !  purpose:
        !
        !  costmi initializes array wsave for use in its companion routines
        !  costmf and costmb.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4
        !
        !  real wsave(lensav), containing the prime factors of n
        !  and also containing certain trigonometric values which will be used
        !  in routines costmb or costmf.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) lensav
        real (wp) dt
        real (wp) fk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lnsv
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: PI = acos(-ONE)
        real (wp) wsave(lensav)

        !
        !==> Check validity of input arguments
        !
        if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('costmi', 3)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n > 3) then

            nm1 = n-1
            np1 = n+1
            ns2 = n/2
            dt = PI/nm1
            fk = ZERO

            do k=2,ns2
                kc = np1-k
                fk = fk + ONE
                wsave(k) = TWO * sin(fk*dt)
                wsave(kc) = TWO * cos(fk*dt)
            end do

            lnsv = nm1 + int(log(real(nm1, kind=wp) )/log(TWO)) + 4

            call rfftmi(nm1, wsave(n+1), lnsv, local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('costmi',-5)
            end if
        end if

    end subroutine costmi

    subroutine costmb(lot, jump, n, inc, x, lenx, wsave, lensav, work, &
        lenwrk, ier)
        !
        ! costmb: 64-bit float precision backward cosine transform, multiple vectors.
        !
        !  purpose:
        !
        !  costmb computes the one-dimensional fourier transform of multiple
        !  even sequences within a real array.  this transform is referred to
        !  as the backward transform or fourier synthesis, transforming the
        !  sequences from spectral to physical space.
        !
        !  this transform is normalized since a call to costmb followed
        !  by a call to costmf (or vice-versa) reproduces the original
        !  array  within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within array r.
        !
        !  integer jump, the increment between the locations, in
        !  array r, of the first elements of two consecutive sequences to be
        !  transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n-1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), array containing lot sequences,
        !  each having length n.  on input, the data to be transformed; on output,
        !  the transormed data.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to costmi before the first call to routine costmf
        !  or costmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to costmf and costmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*(n+1).
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !

        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk

        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) iw1
        integer (ip) jump
        integer (ip) lenx
        integer (ip) lot
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if (lenx < (lot-1)*jump + inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('costmb', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('costmb', 8)
            return
        else if (lenwrk < lot*(n+1)) then
            ier = 3
            call fft_error_handler('costmb', 10)
            return
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ier = 4
            call fft_error_handler('costmb', -1)
            return
        else
            ier = 0
        end if

        ! Set workspace index pointer
        iw1 = 2*lot+1
        call mcstb1(lot,jump,n,inc,x,wsave,work,work(iw1),local_error_flag)

        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('costmb',-5)
        end if

    end subroutine costmb

    subroutine costmf(lot, jump, n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        !  costmf: real cosine transform, multiple vectors.
        !
        !  purpose:
        !
        !  costmf computes the one-dimensional fourier transform of multiple
        !  even sequences within a real array.  this transform is referred to
        !  as the forward transform or fourier analysis, transforming the
        !  sequences from physical to spectral space.
        !
        !  this transform is normalized since a call to costmf followed
        !  by a call to costmb (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within array r.
        !
        !  integer jump, the increment between the locations,
        !  in array r, of the first elements of two consecutive sequences to
        !  be transformed.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n-1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), array containing lot sequences,
        !  each having length n.  on input, the data to be transformed; on output,
        !  the transormed data.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.
        !
        !  integer lenr, the dimension of the  r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to costmi before the first call to routine costmf
        !  or costmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to costmf and costmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least 2*n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*(n+1).
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) iw1
        integer (ip) jump
        integer (ip) lenx
        integer (ip) lot
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if (lenx < (lot-1)*jump + inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('costmf', 6)
            return
        else if (lensav < get_1d_saved_workspace_length(n)) then
            ier = 2
            call fft_error_handler('costmf', 8)
            return
        else if (lenwrk < lot*(n+1)) then
            ier = 3
            call fft_error_handler('costmf', 10)
            return
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ier = 4
            call fft_error_handler('costmf', -1)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        iw1 = 2*lot+1
        call mcstf1(lot,jump,n,inc,x,wsave,work,work(iw1),local_error_flag)

        ! Check error_flag
        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('costmf',-5)
        end if

    end subroutine costmf

    subroutine mcstb1(lot,jump,n,inc,x,wsave,dsum,work,ier)

        integer (ip) inc
        real (wp) dsum(*)
        real (wp) fnm1s2
        real (wp) fnm1s4
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lj
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lot
        integer (ip) m
        integer (ip) m1
        integer (ip) modn
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) x1h
        real (wp) x1p3
        real (wp) x2
        real (wp) xi

        ier = 0

        nm1 = n-1
        np1 = n+1
        ns2 = n/2
        lj = (lot-1)*jump+1

        if (n < 2) then
            return
        else if (n == 2) then
            do m=1,lj,jump
                x1h = x(m,1)+x(m,2)
                x(m,2) = x(m,1)-x(m,2)
                x(m,1) = x1h
            end do
        else
            if (3 >= n) then
                do m=1,lj,jump
                    x1p3 = x(m,1)+x(m,3)
                    x2 = x(m,2)
                    x(m,2) = x(m,1)-x(m,3)
                    x(m,1) = x1p3+x2
                    x(m,3) = x1p3-x2
                end do
            else
                do m=1,lj,jump
                    x(m,1) = x(m,1)+x(m,1)
                    x(m,n) = x(m,n)+x(m,n)
                end do

                m1 = 0

                do m=1,lj,jump
                    m1 = m1+1
                    dsum(m1) = x(m,1)-x(m,n)
                    x(m,1) = x(m,1)+x(m,n)
                end do

                do k=2,ns2
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        kc = np1-k
                        t1 = x(m,k)+x(m,kc)
                        t2 = x(m,k)-x(m,kc)
                        dsum(m1) = dsum(m1)+wsave(kc)*t2
                        t2 = wsave(k)*t2
                        x(m,k) = t1-t2
                        x(m,kc) = t1+t2
                    end do
                end do

                modn = mod(n,2)

                if (modn /= 0) then
                    do m=1,lj,jump
                        x(m,ns2+1) = x(m,ns2+1)+x(m,ns2+1)
                    end do
                end if

                lenx = (lot-1)*jump + inc*(nm1-1)  + 1
                lnsv = nm1 + int(log(real(nm1, kind=wp))/log(TWO)) + 4
                lnwk = lot*nm1

                call rfftmf(lot,jump,nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,local_error_flag)

                if (local_error_flag /= 0) then
                    ier = 20
                    call fft_error_handler('mcstb1',-5)
                    return
                end if

                fnm1s2 = real(nm1, kind=wp)/2
                m1 = 0

                do m=1,lj,jump
                    m1 = m1+1
                    dsum(m1) = HALF * dsum(m1)
                    x(m,1) = fnm1s2 * x(m,1)
                end do

                if (mod(nm1,2) == 0) then
                    do m=1,lj,jump
                        x(m,nm1) = x(m,nm1)+x(m,nm1)
                    end do
                end if

                fnm1s4 = real(nm1, kind=wp)/4

                do i=3,n,2
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        xi = fnm1s4*x(m,i)
                        x(m,i) = fnm1s4*x(m,i-1)
                        x(m,i-1) = dsum(m1)
                        dsum(m1) = dsum(m1)+xi
                    end do
                end do
                if (modn == 0) then
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        x(m,n) = dsum(m1)
                    end do
                end if
            end if
        end if

    end subroutine mcstb1

    subroutine mcstf1(lot,jump,n,inc,x,wsave,dsum,work,ier)

        integer (ip) inc
        real (wp) dsum(*)
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lenx
        integer (ip) lj
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lot
        integer (ip) m
        integer (ip) m1
        integer (ip) modn
        integer (ip) n
        integer (ip) nm1
        integer (ip) np1
        integer (ip) ns2
        real (wp) snm1
        real (wp) t1
        real (wp) t2
        real (wp) tx2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) x1h
        real (wp) x1p3
        real (wp) xi

        ier = 0

        nm1 = n-1
        np1 = n+1
        ns2 = n/2
        lj = (lot-1)*jump+1

        if (n < 2) then
            return
        else if (n == 2) then
            do m=1,lj,jump
                x1h = x(m,1)+x(m,2)
                x(m,2) = HALF * (x(m,1)-x(m,2))
                x(m,1) = HALF * x1h
            end do
        else
            if (3 >= n) then
                do m=1,lj,jump
                    x1p3 = x(m,1)+x(m,3)
                    tx2 = x(m,2)+x(m,2)
                    x(m,2) = HALF * (x(m,1)-x(m,3))
                    x(m,1) = 0.25_wp * (x1p3+tx2)
                    x(m,3) = 0.25_wp * (x1p3-tx2)
                end do
            else
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    dsum(m1) = x(m,1)-x(m,n)
                    x(m,1) = x(m,1)+x(m,n)
                end do
                do k=2,ns2
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        kc = np1-k
                        t1 = x(m,k)+x(m,kc)
                        t2 = x(m,k)-x(m,kc)
                        dsum(m1) = dsum(m1)+wsave(kc)*t2
                        t2 = wsave(k)*t2
                        x(m,k) = t1-t2
                        x(m,kc) = t1+t2
                    end do
                end do

                modn = mod(n,2)

                if (modn /= 0) then
                    do m=1,lj,jump
                        x(m,ns2+1) = x(m,ns2+1)+x(m,ns2+1)
                    end do
                end if

                lenx = (lot-1)*jump + inc*(nm1-1)  + 1
                lnsv = nm1 + int(log(real(nm1, kind=wp))/log(TWO)) + 4
                lnwk = lot*nm1

                call rfftmf(lot,jump,nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,local_error_flag)

                if (local_error_flag /= 0) then
                    ier = 20
                    call fft_error_handler('mcstf1',-5)
                    return
                end if

                snm1 = ONE/nm1

                do m=1,lot
                    dsum(m) = snm1*dsum(m)
                end do

                if (mod(nm1,2) == 0) then
                    do m=1,lj,jump
                        x(m,nm1) = x(m,nm1)+x(m,nm1)
                    end do
                end if

                do i=3,n,2
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        xi = HALF * x(m,i)
                        x(m,i) = HALF * x(m,i-1)
                        x(m,i-1) = dsum(m1)
                        dsum(m1) = dsum(m1)+xi
                    end do
                end do

                if (modn == 0) then
                    m1 = 0
                    do m=1,lj,jump
                        m1 = m1+1
                        x(m,n) = dsum(m1)
                    end do
                end if

                do m=1,lj,jump
                    x(m,1) = HALF * x(m,1)
                    x(m,n) = HALF * x(m,n)
                end do
            end if
        end if

    end subroutine mcstf1

end module cosine_transform_routines


    Program ztgsna_example

!     ZTGSNA Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_dpyth
      Use lapack_interfaces, Only: zlange, ztgevc, ztgsna
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, snorm, stnrm, tnorm
      Integer :: i, info, lda, ldb, ldvl, ldvr, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), vl(:, :), vr(:, :), &
        work(:)
      Real (Kind=dp), Allocatable :: dif(:), rwork(:), s(:)
      Integer, Allocatable :: iwork(:)
      Logical :: select(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'ZTGSNA Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvl = n
      ldvr = n
      lwork = 2*n*n
      Allocate (a(lda,n), b(ldb,n), vl(ldvl,n), vr(ldvr,n), work(lwork), &
        dif(n), rwork(2*n), s(n), iwork(n+2))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Calculate the left and right generalized eigenvectors of the
!     pair (A,B).

      Call ztgevc('Both', 'All', select, n, a, lda, b, ldb, vl, ldvl, vr, &
        ldvr, n, m, work, rwork, info)

!     Estimate condition numbers for all the generalized eigenvalues
!     and right eigenvectors of the pair (A,B)

      Call ztgsna('Both', 'All', select, n, a, lda, b, ldb, vl, ldvl, vr, &
        ldvr, s, dif, n, m, work, lwork, iwork, info)

!     Print condition numbers of eigenvalues and right eigenvectors

      Write (nout, *) 'S'
      Write (nout, 100) s(1:m)
      Write (nout, *)
      Write (nout, *) 'DIF'
      Write (nout, 100) dif(1:m)

!     Calculate approximate error estimates

!     Compute the 1-norms of A and B and then compute
!     SQRT(snorm**2 + tnorm**2)

      eps = epsilon(1.0E0_dp)
      snorm = zlange('1-norm', n, n, a, lda, rwork)
      tnorm = zlange('1-norm', n, n, b, ldb, rwork)
      stnrm = nagf_blas_dpyth(snorm, tnorm)
      Write (nout, *)
      Write (nout, *) 'Approximate error estimates for eigenvalues of (A,B)'
      Write (nout, 100)(eps*stnrm/s(i), i=1, m)
      Write (nout, *)
      Write (nout, *) &
        'Approximate error estimates for right eigenvectors of (A,B)'
      Write (nout, 100)(eps*stnrm/dif(i), i=1, m)

100   Format ((3X,1P,7E11.1))
    End Program


module quad_gauss10_mod
    use :: quad_gauss_mod
    implicit none

    private
    type, public, extends(quad_gauss_t) :: quad_gauss10_t
    contains
        procedure :: init_quad => init_quad10
    end type

    interface quad_gauss10_t
        module procedure :: create_quad
    end interface

contains

    function create_quad() result(quad)
        implicit none
        type(quad_gauss10_t) :: quad
        call quad%init_quad()
    end function create_quad

    subroutine init_quad10(this)
        implicit none
        class(quad_gauss10_t), intent(inout) :: this

        call this%set_abscissae([ &
            -0.1488743389816312,  &
             0.1488743389816312,  &
            -0.4333953941292472,  &
             0.4333953941292472,  &
            -0.6794095682990244,  &
             0.6794095682990244,  &
            -0.8650633666889845,  &
             0.8650633666889845,  &
            -0.9739065285171717,  &
             0.9739065285171717   &
        ])

        call this%set_weights([ &
            0.2955242247147529, &
            0.2955242247147529, &
            0.2692667193099963, &
            0.2692667193099963, &
            0.2190863625159820, &
            0.2190863625159820, &
            0.1494513491505806, &
            0.1494513491505806, &
            0.0666713443086881, &
            0.0666713443086881  &
        ])
    end subroutine init_quad10

end module quad_gauss10_mod


*> \brief \b SLATMR
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
*                          RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
*                          CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
*                          PACK, A, LDA, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
*       INTEGER            INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
*       REAL               ANORM, COND, CONDL, CONDR, DMAX, SPARSE
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIVOT( * ), ISEED( 4 ), IWORK( * )
*       REAL               A( LDA, * ), D( * ), DL( * ), DR( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SLATMR generates random matrices of various types for testing
*>    LAPACK programs.
*>
*>    SLATMR operates by applying the following sequence of
*>    operations:
*>
*>      Generate a matrix A with random entries of distribution DIST
*>         which is symmetric if SYM='S', and nonsymmetric
*>         if SYM='N'.
*>
*>      Set the diagonal to D, where D may be input or
*>         computed according to MODE, COND, DMAX and RSIGN
*>         as described below.
*>
*>      Grade the matrix, if desired, from the left and/or right
*>         as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
*>         MODER and CONDR also determine the grading as described
*>         below.
*>
*>      Permute, if desired, the rows and/or columns as specified by
*>         PIVTNG and IPIVOT.
*>
*>      Set random entries to zero, if desired, to get a random sparse
*>         matrix as specified by SPARSE.
*>
*>      Make A a band matrix, if desired, by zeroing out the matrix
*>         outside a band of lower bandwidth KL and upper bandwidth KU.
*>
*>      Scale A, if desired, to have maximum entry ANORM.
*>
*>      Pack the matrix if desired. Options specified by PACK are:
*>         no packing
*>         zero out upper half (if symmetric)
*>         zero out lower half (if symmetric)
*>         store the upper half columnwise (if symmetric or
*>             square upper triangular)
*>         store the lower half columnwise (if symmetric or
*>             square lower triangular)
*>             same as upper half rowwise if symmetric
*>         store the lower triangle in banded format (if symmetric)
*>         store the upper triangle in banded format (if symmetric)
*>         store the entire matrix in banded format
*>
*>    Note: If two calls to SLATMR differ only in the PACK parameter,
*>          they will generate mathematically equivalent matrices.
*>
*>          If two calls to SLATMR both have full bandwidth (KL = M-1
*>          and KU = N-1), and differ only in the PIVTNG and PACK
*>          parameters, then the matrices generated will differ only
*>          in the order of the rows and/or columns, and otherwise
*>          contain the same data. This consistency cannot be and
*>          is not maintained with less than full bandwidth.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>           Number of rows of A. Not modified.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           Number of columns of A. Not modified.
*> \endverbatim
*>
*> \param[in] DIST
*> \verbatim
*>          DIST is CHARACTER*1
*>           On entry, DIST specifies the type of distribution to be used
*>           to generate a random matrix .
*>           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
*>           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
*>           'N' => NORMAL( 0, 1 )   ( 'N' for normal )
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>           On entry ISEED specifies the seed of the random number
*>           generator. They should lie between 0 and 4095 inclusive,
*>           and ISEED(4) should be odd. The random number generator
*>           uses a linear congruential sequence limited to small
*>           integers, and so should produce machine independent
*>           random numbers. The values of ISEED are changed on
*>           exit, and can be used in the next call to SLATMR
*>           to continue the same random number sequence.
*>           Changed on exit.
*> \endverbatim
*>
*> \param[in] SYM
*> \verbatim
*>          SYM is CHARACTER*1
*>           If SYM='S' or 'H', generated matrix is symmetric.
*>           If SYM='N', generated matrix is nonsymmetric.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (min(M,N))
*>           On entry this array specifies the diagonal entries
*>           of the diagonal of A.  D may either be specified
*>           on entry, or set according to MODE and COND as described
*>           below. May be changed on exit if MODE is nonzero.
*> \endverbatim
*>
*> \param[in] MODE
*> \verbatim
*>          MODE is INTEGER
*>           On entry describes how D is to be used:
*>           MODE = 0 means use D as input
*>           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
*>           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
*>           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
*>           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
*>           MODE = 5 sets D to random numbers in the range
*>                    ( 1/COND , 1 ) such that their logarithms
*>                    are uniformly distributed.
*>           MODE = 6 set D to random numbers from same distribution
*>                    as the rest of the matrix.
*>           MODE < 0 has the same meaning as ABS(MODE), except that
*>              the order of the elements of D is reversed.
*>           Thus if MODE is positive, D has entries ranging from
*>              1 to 1/COND, if negative, from 1/COND to 1,
*>           Not modified.
*> \endverbatim
*>
*> \param[in] COND
*> \verbatim
*>          COND is REAL
*>           On entry, used as described under MODE above.
*>           If used, it must be >= 1. Not modified.
*> \endverbatim
*>
*> \param[in] DMAX
*> \verbatim
*>          DMAX is REAL
*>           If MODE neither -6, 0 nor 6, the diagonal is scaled by
*>           DMAX / max(abs(D(i))), so that maximum absolute entry
*>           of diagonal is abs(DMAX). If DMAX is negative (or zero),
*>           diagonal will be scaled by a negative number (or zero).
*> \endverbatim
*>
*> \param[in] RSIGN
*> \verbatim
*>          RSIGN is CHARACTER*1
*>           If MODE neither -6, 0 nor 6, specifies sign of diagonal
*>           as follows:
*>           'T' => diagonal entries are multiplied by 1 or -1
*>                  with probability .5
*>           'F' => diagonal unchanged
*>           Not modified.
*> \endverbatim
*>
*> \param[in] GRADE
*> \verbatim
*>          GRADE is CHARACTER*1
*>           Specifies grading of matrix as follows:
*>           'N'  => no grading
*>           'L'  => matrix premultiplied by diag( DL )
*>                   (only if matrix nonsymmetric)
*>           'R'  => matrix postmultiplied by diag( DR )
*>                   (only if matrix nonsymmetric)
*>           'B'  => matrix premultiplied by diag( DL ) and
*>                         postmultiplied by diag( DR )
*>                   (only if matrix nonsymmetric)
*>           'S' or 'H'  => matrix premultiplied by diag( DL ) and
*>                          postmultiplied by diag( DL )
*>                          ('S' for symmetric, or 'H' for Hermitian)
*>           'E'  => matrix premultiplied by diag( DL ) and
*>                         postmultiplied by inv( diag( DL ) )
*>                         ( 'E' for eigenvalue invariance)
*>                   (only if matrix nonsymmetric)
*>                   Note: if GRADE='E', then M must equal N.
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] DL
*> \verbatim
*>          DL is REAL array, dimension (M)
*>           If MODEL=0, then on entry this array specifies the diagonal
*>           entries of a diagonal matrix used as described under GRADE
*>           above. If MODEL is not zero, then DL will be set according
*>           to MODEL and CONDL, analogous to the way D is set according
*>           to MODE and COND (except there is no DMAX parameter for DL).
*>           If GRADE='E', then DL cannot have zero entries.
*>           Not referenced if GRADE = 'N' or 'R'. Changed on exit.
*> \endverbatim
*>
*> \param[in] MODEL
*> \verbatim
*>          MODEL is INTEGER
*>           This specifies how the diagonal array DL is to be computed,
*>           just as MODE specifies how D is to be computed.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] CONDL
*> \verbatim
*>          CONDL is REAL
*>           When MODEL is not zero, this specifies the condition number
*>           of the computed DL.  Not modified.
*> \endverbatim
*>
*> \param[in,out] DR
*> \verbatim
*>          DR is REAL array, dimension (N)
*>           If MODER=0, then on entry this array specifies the diagonal
*>           entries of a diagonal matrix used as described under GRADE
*>           above. If MODER is not zero, then DR will be set according
*>           to MODER and CONDR, analogous to the way D is set according
*>           to MODE and COND (except there is no DMAX parameter for DR).
*>           Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'.
*>           Changed on exit.
*> \endverbatim
*>
*> \param[in] MODER
*> \verbatim
*>          MODER is INTEGER
*>           This specifies how the diagonal array DR is to be computed,
*>           just as MODE specifies how D is to be computed.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] CONDR
*> \verbatim
*>          CONDR is REAL
*>           When MODER is not zero, this specifies the condition number
*>           of the computed DR.  Not modified.
*> \endverbatim
*>
*> \param[in] PIVTNG
*> \verbatim
*>          PIVTNG is CHARACTER*1
*>           On entry specifies pivoting permutations as follows:
*>           'N' or ' ' => none.
*>           'L' => left or row pivoting (matrix must be nonsymmetric).
*>           'R' => right or column pivoting (matrix must be
*>                  nonsymmetric).
*>           'B' or 'F' => both or full pivoting, i.e., on both sides.
*>                         In this case, M must equal N
*>
*>           If two calls to SLATMR both have full bandwidth (KL = M-1
*>           and KU = N-1), and differ only in the PIVTNG and PACK
*>           parameters, then the matrices generated will differ only
*>           in the order of the rows and/or columns, and otherwise
*>           contain the same data. This consistency cannot be
*>           maintained with less than full bandwidth.
*> \endverbatim
*>
*> \param[in] IPIVOT
*> \verbatim
*>          IPIVOT is INTEGER array, dimension (N or M)
*>           This array specifies the permutation used.  After the
*>           basic matrix is generated, the rows, columns, or both
*>           are permuted.   If, say, row pivoting is selected, SLATMR
*>           starts with the *last* row and interchanges the M-th and
*>           IPIVOT(M)-th rows, then moves to the next-to-last row,
*>           interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
*>           and so on.  In terms of "2-cycles", the permutation is
*>           (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
*>           where the rightmost cycle is applied first.  This is the
*>           *inverse* of the effect of pivoting in LINPACK.  The idea
*>           is that factoring (with pivoting) an identity matrix
*>           which has been inverse-pivoted in this way should
*>           result in a pivot vector identical to IPIVOT.
*>           Not referenced if PIVTNG = 'N'. Not modified.
*> \endverbatim
*>
*> \param[in] SPARSE
*> \verbatim
*>          SPARSE is REAL
*>           On entry specifies the sparsity of the matrix if a sparse
*>           matrix is to be generated. SPARSE should lie between
*>           0 and 1. To generate a sparse matrix, for each matrix entry
*>           a uniform ( 0, 1 ) random number x is generated and
*>           compared to SPARSE; if x is larger the matrix entry
*>           is unchanged and if x is smaller the entry is set
*>           to zero. Thus on the average a fraction SPARSE of the
*>           entries will be set to zero.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>           On entry specifies the lower bandwidth of the  matrix. For
*>           example, KL=0 implies upper triangular, KL=1 implies upper
*>           Hessenberg, and KL at least M-1 implies the matrix is not
*>           banded. Must equal KU if matrix is symmetric.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>           On entry specifies the upper bandwidth of the  matrix. For
*>           example, KU=0 implies lower triangular, KU=1 implies lower
*>           Hessenberg, and KU at least N-1 implies the matrix is not
*>           banded. Must equal KL if matrix is symmetric.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*>          ANORM is REAL
*>           On entry specifies maximum entry of output matrix
*>           (output matrix will by multiplied by a constant so that
*>           its largest absolute entry equal ANORM)
*>           if ANORM is nonnegative. If ANORM is negative no scaling
*>           is done. Not modified.
*> \endverbatim
*>
*> \param[in] PACK
*> \verbatim
*>          PACK is CHARACTER*1
*>           On entry specifies packing of matrix as follows:
*>           'N' => no packing
*>           'U' => zero out all subdiagonal entries (if symmetric)
*>           'L' => zero out all superdiagonal entries (if symmetric)
*>           'C' => store the upper triangle columnwise
*>                  (only if matrix symmetric or square upper triangular)
*>           'R' => store the lower triangle columnwise
*>                  (only if matrix symmetric or square lower triangular)
*>                  (same as upper half rowwise if symmetric)
*>           'B' => store the lower triangle in band storage scheme
*>                  (only if matrix symmetric)
*>           'Q' => store the upper triangle in band storage scheme
*>                  (only if matrix symmetric)
*>           'Z' => store the entire matrix in band storage scheme
*>                      (pivoting can be provided for by using this
*>                      option to store A in the trailing rows of
*>                      the allocated storage)
*>
*>           Using these options, the various LAPACK packed and banded
*>           storage schemes can be obtained:
*>           GB               - use 'Z'
*>           PB, SB or TB     - use 'B' or 'Q'
*>           PP, SP or TP     - use 'C' or 'R'
*>
*>           If two calls to SLATMR differ only in the PACK parameter,
*>           they will generate mathematically equivalent matrices.
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>           On exit A is the desired test matrix. Only those
*>           entries of A which are significant on output
*>           will be referenced (even if A is in packed or band
*>           storage format). The 'unoccupied corners' of A in
*>           band format will be zeroed out.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           on entry LDA specifies the first dimension of A as
*>           declared in the calling program.
*>           If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
*>           If PACK='C' or 'R', LDA must be at least 1.
*>           If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
*>           If PACK='Z', LDA must be at least KUU+KLL+1, where
*>           KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 )
*>           Not modified.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension ( N or M)
*>           Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>           Error parameter on exit:
*>             0 => normal return
*>            -1 => M negative or unequal to N and SYM='S' or 'H'
*>            -2 => N negative
*>            -3 => DIST illegal string
*>            -5 => SYM illegal string
*>            -7 => MODE not in range -6 to 6
*>            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
*>           -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
*>           -11 => GRADE illegal string, or GRADE='E' and
*>                  M not equal to N, or GRADE='L', 'R', 'B' or 'E' and
*>                  SYM = 'S' or 'H'
*>           -12 => GRADE = 'E' and DL contains zero
*>           -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
*>                  'S' or 'E'
*>           -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
*>                  and MODEL neither -6, 0 nor 6
*>           -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
*>           -17 => CONDR less than 1.0, GRADE='R' or 'B', and
*>                  MODER neither -6, 0 nor 6
*>           -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
*>                  M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
*>                  or 'H'
*>           -19 => IPIVOT contains out of range number and
*>                  PIVTNG not equal to 'N'
*>           -20 => KL negative
*>           -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
*>           -22 => SPARSE not in range 0. to 1.
*>           -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
*>                  and SYM='N', or PACK='C' and SYM='N' and either KL
*>                  not equal to 0 or N not equal to M, or PACK='R' and
*>                  SYM='N', and either KU not equal to 0 or N not equal
*>                  to M
*>           -26 => LDA too small
*>             1 => Error return from SLATM1 (computing D)
*>             2 => Cannot scale diagonal to DMAX (max. entry is 0)
*>             3 => Error return from SLATM1 (computing DL)
*>             4 => Error return from SLATM1 (computing DR)
*>             5 => ANORM is positive, but matrix constructed prior to
*>                  attempting to scale it to have norm ANORM, is zero
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup real_matgen
*
*  =====================================================================
      SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
     $                   RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
     $                   CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
     $                   PACK, A, LDA, IWORK, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
      INTEGER            INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
      REAL               ANORM, COND, CONDL, CONDR, DMAX, SPARSE
*     ..
*     .. Array Arguments ..
      INTEGER            IPIVOT( * ), ISEED( 4 ), IWORK( * )
      REAL               A( LDA, * ), D( * ), DL( * ), DR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADPVT, DZERO, FULBND
      INTEGER            I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
     $                   ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
     $                   MNSUB, MXSUB, NPVTS
      REAL               ALPHA, ONORM, TEMP
*     ..
*     .. Local Arrays ..
      REAL               TEMPA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLANGB, SLANGE, SLANSB, SLANSP, SLANSY, SLATM2,
     $                   SLATM3
      EXTERNAL           LSAME, SLANGB, SLANGE, SLANSB, SLANSP, SLANSY,
     $                   SLATM2, SLATM3
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLATM1, SSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*
*     1)      Decode and Test the input parameters.
*             Initialize flags & seed.
*
      INFO = 0
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Decode DIST
*
      IF( LSAME( DIST, 'U' ) ) THEN
         IDIST = 1
      ELSE IF( LSAME( DIST, 'S' ) ) THEN
         IDIST = 2
      ELSE IF( LSAME( DIST, 'N' ) ) THEN
         IDIST = 3
      ELSE
         IDIST = -1
      END IF
*
*     Decode SYM
*
      IF( LSAME( SYM, 'S' ) ) THEN
         ISYM = 0
      ELSE IF( LSAME( SYM, 'N' ) ) THEN
         ISYM = 1
      ELSE IF( LSAME( SYM, 'H' ) ) THEN
         ISYM = 0
      ELSE
         ISYM = -1
      END IF
*
*     Decode RSIGN
*
      IF( LSAME( RSIGN, 'F' ) ) THEN
         IRSIGN = 0
      ELSE IF( LSAME( RSIGN, 'T' ) ) THEN
         IRSIGN = 1
      ELSE
         IRSIGN = -1
      END IF
*
*     Decode PIVTNG
*
      IF( LSAME( PIVTNG, 'N' ) ) THEN
         IPVTNG = 0
      ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN
         IPVTNG = 0
      ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN
         IPVTNG = 1
         NPVTS = M
      ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN
         IPVTNG = 2
         NPVTS = N
      ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN
         IPVTNG = 3
         NPVTS = MIN( N, M )
      ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN
         IPVTNG = 3
         NPVTS = MIN( N, M )
      ELSE
         IPVTNG = -1
      END IF
*
*     Decode GRADE
*
      IF( LSAME( GRADE, 'N' ) ) THEN
         IGRADE = 0
      ELSE IF( LSAME( GRADE, 'L' ) ) THEN
         IGRADE = 1
      ELSE IF( LSAME( GRADE, 'R' ) ) THEN
         IGRADE = 2
      ELSE IF( LSAME( GRADE, 'B' ) ) THEN
         IGRADE = 3
      ELSE IF( LSAME( GRADE, 'E' ) ) THEN
         IGRADE = 4
      ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN
         IGRADE = 5
      ELSE
         IGRADE = -1
      END IF
*
*     Decode PACK
*
      IF( LSAME( PACK, 'N' ) ) THEN
         IPACK = 0
      ELSE IF( LSAME( PACK, 'U' ) ) THEN
         IPACK = 1
      ELSE IF( LSAME( PACK, 'L' ) ) THEN
         IPACK = 2
      ELSE IF( LSAME( PACK, 'C' ) ) THEN
         IPACK = 3
      ELSE IF( LSAME( PACK, 'R' ) ) THEN
         IPACK = 4
      ELSE IF( LSAME( PACK, 'B' ) ) THEN
         IPACK = 5
      ELSE IF( LSAME( PACK, 'Q' ) ) THEN
         IPACK = 6
      ELSE IF( LSAME( PACK, 'Z' ) ) THEN
         IPACK = 7
      ELSE
         IPACK = -1
      END IF
*
*     Set certain internal parameters
*
      MNMIN = MIN( M, N )
      KLL = MIN( KL, M-1 )
      KUU = MIN( KU, N-1 )
*
*     If inv(DL) is used, check to see if DL has a zero entry.
*
      DZERO = .FALSE.
      IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN
         DO 10 I = 1, M
            IF( DL( I ).EQ.ZERO )
     $         DZERO = .TRUE.
   10    CONTINUE
      END IF
*
*     Check values in IPIVOT
*
      BADPVT = .FALSE.
      IF( IPVTNG.GT.0 ) THEN
         DO 20 J = 1, NPVTS
            IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS )
     $         BADPVT = .TRUE.
   20    CONTINUE
      END IF
*
*     Set INFO if an error
*
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( IDIST.EQ.-1 ) THEN
         INFO = -3
      ELSE IF( ISYM.EQ.-1 ) THEN
         INFO = -5
      ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
         INFO = -7
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         COND.LT.ONE ) THEN
         INFO = -8
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         IRSIGN.EQ.-1 ) THEN
         INFO = -10
      ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR.
     $         ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) )
     $          THEN
         INFO = -11
      ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN
         INFO = -12
      ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
     $         IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) )
     $          THEN
         INFO = -13
      ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR.
     $         IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND.
     $         MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN
         INFO = -14
      ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
     $         ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN
         INFO = -16
      ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND.
     $         ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND.
     $         CONDR.LT.ONE ) THEN
         INFO = -17
      ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR.
     $         ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) )
     $          THEN
         INFO = -18
      ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN
         INFO = -19
      ELSE IF( KL.LT.0 ) THEN
         INFO = -20
      ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN
         INFO = -21
      ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN
         INFO = -22
      ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR.
     $         IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR.
     $         ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE.
     $         N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE.
     $         0 .OR. M.NE.N ) ) ) THEN
         INFO = -24
      ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND.
     $         LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ.
     $         4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ.
     $         6 ) .AND. LDA.LT.KUU+1 ) .OR.
     $         ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN
         INFO = -26
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLATMR', -INFO )
         RETURN
      END IF
*
*     Decide if we can pivot consistently
*
      FULBND = .FALSE.
      IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 )
     $   FULBND = .TRUE.
*
*     Initialize random number generator
*
      DO 30 I = 1, 4
         ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
   30 CONTINUE
*
      ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1
*
*     2)      Set up D, DL, and DR, if indicated.
*
*             Compute D according to COND and MODE
*
      CALL SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN
*
*        Scale by DMAX
*
         TEMP = ABS( D( 1 ) )
         DO 40 I = 2, MNMIN
            TEMP = MAX( TEMP, ABS( D( I ) ) )
   40    CONTINUE
         IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN
            INFO = 2
            RETURN
         END IF
         IF( TEMP.NE.ZERO ) THEN
            ALPHA = DMAX / TEMP
         ELSE
            ALPHA = ONE
         END IF
         DO 50 I = 1, MNMIN
            D( I ) = ALPHA*D( I )
   50    CONTINUE
*
      END IF
*
*     Compute DL if grading set
*
      IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ.
     $    5 ) THEN
         CALL SLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 3
            RETURN
         END IF
      END IF
*
*     Compute DR if grading set
*
      IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN
         CALL SLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
      END IF
*
*     3)     Generate IWORK if pivoting
*
      IF( IPVTNG.GT.0 ) THEN
         DO 60 I = 1, NPVTS
            IWORK( I ) = I
   60    CONTINUE
         IF( FULBND ) THEN
            DO 70 I = 1, NPVTS
               K = IPIVOT( I )
               J = IWORK( I )
               IWORK( I ) = IWORK( K )
               IWORK( K ) = J
   70       CONTINUE
         ELSE
            DO 80 I = NPVTS, 1, -1
               K = IPIVOT( I )
               J = IWORK( I )
               IWORK( I ) = IWORK( K )
               IWORK( K ) = J
   80       CONTINUE
         END IF
      END IF
*
*     4)      Generate matrices for each kind of PACKing
*             Always sweep matrix columnwise (if symmetric, upper
*             half only) so that matrix generated does not depend
*             on PACK
*
      IF( FULBND ) THEN
*
*        Use SLATM3 so matrices generated with differing PIVOTing only
*        differ only in the order of their rows and/or columns.
*
         IF( IPACK.EQ.0 ) THEN
            IF( ISYM.EQ.0 ) THEN
               DO 100 J = 1, N
                  DO 90 I = 1, J
                     TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                      IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                      IWORK, SPARSE )
                     A( ISUB, JSUB ) = TEMP
                     A( JSUB, ISUB ) = TEMP
   90             CONTINUE
  100          CONTINUE
            ELSE IF( ISYM.EQ.1 ) THEN
               DO 120 J = 1, N
                  DO 110 I = 1, M
                     TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                      IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                      IWORK, SPARSE )
                     A( ISUB, JSUB ) = TEMP
  110             CONTINUE
  120          CONTINUE
            END IF
*
         ELSE IF( IPACK.EQ.1 ) THEN
*
            DO 140 J = 1, N
               DO 130 I = 1, J
                  TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                   ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                   SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  A( MNSUB, MXSUB ) = TEMP
                  IF( MNSUB.NE.MXSUB )
     $               A( MXSUB, MNSUB ) = ZERO
  130          CONTINUE
  140       CONTINUE
*
         ELSE IF( IPACK.EQ.2 ) THEN
*
            DO 160 J = 1, N
               DO 150 I = 1, J
                  TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                   ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                   SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  A( MXSUB, MNSUB ) = TEMP
                  IF( MNSUB.NE.MXSUB )
     $               A( MNSUB, MXSUB ) = ZERO
  150          CONTINUE
  160       CONTINUE
*
         ELSE IF( IPACK.EQ.3 ) THEN
*
            DO 180 J = 1, N
               DO 170 I = 1, J
                  TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                   ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                   SPARSE )
*
*                 Compute K = location of (ISUB,JSUB) entry in packed
*                 array
*
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  K = MXSUB*( MXSUB-1 ) / 2 + MNSUB
*
*                 Convert K to (IISUB,JJSUB) location
*
                  JJSUB = ( K-1 ) / LDA + 1
                  IISUB = K - LDA*( JJSUB-1 )
*
                  A( IISUB, JJSUB ) = TEMP
  170          CONTINUE
  180       CONTINUE
*
         ELSE IF( IPACK.EQ.4 ) THEN
*
            DO 200 J = 1, N
               DO 190 I = 1, J
                  TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                   ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                   SPARSE )
*
*                 Compute K = location of (I,J) entry in packed array
*
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  IF( MNSUB.EQ.1 ) THEN
                     K = MXSUB
                  ELSE
                     K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) /
     $                   2 + MXSUB - MNSUB + 1
                  END IF
*
*                 Convert K to (IISUB,JJSUB) location
*
                  JJSUB = ( K-1 ) / LDA + 1
                  IISUB = K - LDA*( JJSUB-1 )
*
                  A( IISUB, JJSUB ) = TEMP
  190          CONTINUE
  200       CONTINUE
*
         ELSE IF( IPACK.EQ.5 ) THEN
*
            DO 220 J = 1, N
               DO 210 I = J - KUU, J
                  IF( I.LT.1 ) THEN
                     A( J-I+1, I+N ) = ZERO
                  ELSE
                     TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                      IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                      IWORK, SPARSE )
                     MNSUB = MIN( ISUB, JSUB )
                     MXSUB = MAX( ISUB, JSUB )
                     A( MXSUB-MNSUB+1, MNSUB ) = TEMP
                  END IF
  210          CONTINUE
  220       CONTINUE
*
         ELSE IF( IPACK.EQ.6 ) THEN
*
            DO 240 J = 1, N
               DO 230 I = J - KUU, J
                  TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST,
     $                   ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK,
     $                   SPARSE )
                  MNSUB = MIN( ISUB, JSUB )
                  MXSUB = MAX( ISUB, JSUB )
                  A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
  230          CONTINUE
  240       CONTINUE
*
         ELSE IF( IPACK.EQ.7 ) THEN
*
            IF( ISYM.EQ.0 ) THEN
               DO 260 J = 1, N
                  DO 250 I = J - KUU, J
                     TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                      IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                      IWORK, SPARSE )
                     MNSUB = MIN( ISUB, JSUB )
                     MXSUB = MAX( ISUB, JSUB )
                     A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP
                     IF( I.LT.1 )
     $                  A( J-I+1+KUU, I+N ) = ZERO
                     IF( I.GE.1 .AND. MNSUB.NE.MXSUB )
     $                  A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP
  250             CONTINUE
  260          CONTINUE
            ELSE IF( ISYM.EQ.1 ) THEN
               DO 280 J = 1, N
                  DO 270 I = J - KUU, J + KLL
                     TEMP = SLATM3( M, N, I, J, ISUB, JSUB, KL, KU,
     $                      IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                      IWORK, SPARSE )
                     A( ISUB-JSUB+KUU+1, JSUB ) = TEMP
  270             CONTINUE
  280          CONTINUE
            END IF
*
         END IF
*
      ELSE
*
*        Use SLATM2
*
         IF( IPACK.EQ.0 ) THEN
            IF( ISYM.EQ.0 ) THEN
               DO 300 J = 1, N
                  DO 290 I = 1, J
                     A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
     $                           ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                           IWORK, SPARSE )
                     A( J, I ) = A( I, J )
  290             CONTINUE
  300          CONTINUE
            ELSE IF( ISYM.EQ.1 ) THEN
               DO 320 J = 1, N
                  DO 310 I = 1, M
                     A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
     $                           ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                           IWORK, SPARSE )
  310             CONTINUE
  320          CONTINUE
            END IF
*
         ELSE IF( IPACK.EQ.1 ) THEN
*
            DO 340 J = 1, N
               DO 330 I = 1, J
                  A( I, J ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
     $                        D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
                  IF( I.NE.J )
     $               A( J, I ) = ZERO
  330          CONTINUE
  340       CONTINUE
*
         ELSE IF( IPACK.EQ.2 ) THEN
*
            DO 360 J = 1, N
               DO 350 I = 1, J
                  A( J, I ) = SLATM2( M, N, I, J, KL, KU, IDIST, ISEED,
     $                        D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE )
                  IF( I.NE.J )
     $               A( I, J ) = ZERO
  350          CONTINUE
  360       CONTINUE
*
         ELSE IF( IPACK.EQ.3 ) THEN
*
            ISUB = 0
            JSUB = 1
            DO 380 J = 1, N
               DO 370 I = 1, J
                  ISUB = ISUB + 1
                  IF( ISUB.GT.LDA ) THEN
                     ISUB = 1
                     JSUB = JSUB + 1
                  END IF
                  A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU, IDIST,
     $                              ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                              IWORK, SPARSE )
  370          CONTINUE
  380       CONTINUE
*
         ELSE IF( IPACK.EQ.4 ) THEN
*
            IF( ISYM.EQ.0 ) THEN
               DO 400 J = 1, N
                  DO 390 I = 1, J
*
*                    Compute K = location of (I,J) entry in packed array
*
                     IF( I.EQ.1 ) THEN
                        K = J
                     ELSE
                        K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 +
     $                      J - I + 1
                     END IF
*
*                    Convert K to (ISUB,JSUB) location
*
                     JSUB = ( K-1 ) / LDA + 1
                     ISUB = K - LDA*( JSUB-1 )
*
                     A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU,
     $                                 IDIST, ISEED, D, IGRADE, DL, DR,
     $                                 IPVTNG, IWORK, SPARSE )
  390             CONTINUE
  400          CONTINUE
            ELSE
               ISUB = 0
               JSUB = 1
               DO 420 J = 1, N
                  DO 410 I = J, M
                     ISUB = ISUB + 1
                     IF( ISUB.GT.LDA ) THEN
                        ISUB = 1
                        JSUB = JSUB + 1
                     END IF
                     A( ISUB, JSUB ) = SLATM2( M, N, I, J, KL, KU,
     $                                 IDIST, ISEED, D, IGRADE, DL, DR,
     $                                 IPVTNG, IWORK, SPARSE )
  410             CONTINUE
  420          CONTINUE
            END IF
*
         ELSE IF( IPACK.EQ.5 ) THEN
*
            DO 440 J = 1, N
               DO 430 I = J - KUU, J
                  IF( I.LT.1 ) THEN
                     A( J-I+1, I+N ) = ZERO
                  ELSE
                     A( J-I+1, I ) = SLATM2( M, N, I, J, KL, KU, IDIST,
     $                               ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                               IWORK, SPARSE )
                  END IF
  430          CONTINUE
  440       CONTINUE
*
         ELSE IF( IPACK.EQ.6 ) THEN
*
            DO 460 J = 1, N
               DO 450 I = J - KUU, J
                  A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU, IDIST,
     $                                ISEED, D, IGRADE, DL, DR, IPVTNG,
     $                                IWORK, SPARSE )
  450          CONTINUE
  460       CONTINUE
*
         ELSE IF( IPACK.EQ.7 ) THEN
*
            IF( ISYM.EQ.0 ) THEN
               DO 480 J = 1, N
                  DO 470 I = J - KUU, J
                     A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU,
     $                                   IDIST, ISEED, D, IGRADE, DL,
     $                                   DR, IPVTNG, IWORK, SPARSE )
                     IF( I.LT.1 )
     $                  A( J-I+1+KUU, I+N ) = ZERO
                     IF( I.GE.1 .AND. I.NE.J )
     $                  A( J-I+1+KUU, I ) = A( I-J+KUU+1, J )
  470             CONTINUE
  480          CONTINUE
            ELSE IF( ISYM.EQ.1 ) THEN
               DO 500 J = 1, N
                  DO 490 I = J - KUU, J + KLL
                     A( I-J+KUU+1, J ) = SLATM2( M, N, I, J, KL, KU,
     $                                   IDIST, ISEED, D, IGRADE, DL,
     $                                   DR, IPVTNG, IWORK, SPARSE )
  490             CONTINUE
  500          CONTINUE
            END IF
*
         END IF
*
      END IF
*
*     5)      Scaling the norm
*
      IF( IPACK.EQ.0 ) THEN
         ONORM = SLANGE( 'M', M, N, A, LDA, TEMPA )
      ELSE IF( IPACK.EQ.1 ) THEN
         ONORM = SLANSY( 'M', 'U', N, A, LDA, TEMPA )
      ELSE IF( IPACK.EQ.2 ) THEN
         ONORM = SLANSY( 'M', 'L', N, A, LDA, TEMPA )
      ELSE IF( IPACK.EQ.3 ) THEN
         ONORM = SLANSP( 'M', 'U', N, A, TEMPA )
      ELSE IF( IPACK.EQ.4 ) THEN
         ONORM = SLANSP( 'M', 'L', N, A, TEMPA )
      ELSE IF( IPACK.EQ.5 ) THEN
         ONORM = SLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA )
      ELSE IF( IPACK.EQ.6 ) THEN
         ONORM = SLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA )
      ELSE IF( IPACK.EQ.7 ) THEN
         ONORM = SLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA )
      END IF
*
      IF( ANORM.GE.ZERO ) THEN
*
         IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN
*
*           Desired scaling impossible
*
            INFO = 5
            RETURN
*
         ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR.
     $            ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN
*
*           Scale carefully to avoid over / underflow
*
            IF( IPACK.LE.2 ) THEN
               DO 510 J = 1, N
                  CALL SSCAL( M, ONE / ONORM, A( 1, J ), 1 )
                  CALL SSCAL( M, ANORM, A( 1, J ), 1 )
  510          CONTINUE
*
            ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
               CALL SSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 )
               CALL SSCAL( N*( N+1 ) / 2, ANORM, A, 1 )
*
            ELSE IF( IPACK.GE.5 ) THEN
*
               DO 520 J = 1, N
                  CALL SSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 )
                  CALL SSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 )
  520          CONTINUE
*
            END IF
*
         ELSE
*
*           Scale straightforwardly
*
            IF( IPACK.LE.2 ) THEN
               DO 530 J = 1, N
                  CALL SSCAL( M, ANORM / ONORM, A( 1, J ), 1 )
  530          CONTINUE
*
            ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN
*
               CALL SSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 )
*
            ELSE IF( IPACK.GE.5 ) THEN
*
               DO 540 J = 1, N
                  CALL SSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 )
  540          CONTINUE
            END IF
*
         END IF
*
      END IF
*
*     End of SLATMR
*
      END


module box_pot_parameters
    use types
    implicit none
    public
! CONSTANT PARAMETERS
    ! pot arguments
    real(dp), parameter :: dlr = 50.0_dp, dT = 1.4737_dp
    real(dp), parameter :: dla = 49.0_dp, deltat = 0.00001_dp
    real(dp), parameter :: a2 = (dlr/(dlr-dla))*(dlr/dla)**(dla/(dlr-dla))
    real(dp), parameter :: bpot = (dlr/dla)**(1.0_dp/(dlr-dla))

    ! parameters arguments
    real(dp), parameter :: pi = acos(-1.0_dp)

    real(dp), parameter :: diam = 1.0_dp
    real(dp), parameter :: sqtwodt = sqrt(2.0_dp*deltat)

    ! Dependen del usuario
    real(dp) :: phi, rho, boxl, rc
    integer :: np, mt
    logical :: with_ih ! Para prender o apagar las IH

    ! mp and mr arguments
    integer, parameter :: mp = 1024, mr = 2**9
end module box_pot_parameters


!********************************************************************
	SUBROUTINE LAKENUM(ULKN,lk)
!*******************************************************************
!
!        lakenumber
!       ---------------
!
!MC     THIS ROUTINE CALCULATES THE lakenumber FOR THE CURRENT DAY
!MC     AND SENDS THE OUTPUT TO A FILE:'Ldddhhmm.NUM'
!KLG  i.e. has the same name as the simulation file
!MC
!MC     ALGORITHM FROM PROGRAM "LAKE NUMBER PROJECT" (11/8/1991)
!MC
!MC     WRITTEN BY:     STEPHEN BARRY AND JOHN SNELL
!MC
!MC     FOR:            CENTRE FOR WATER RESEARCH, UNIVERSITY OF W.A.
!MC
!MC     TRANSLATED FROM C LANGUAGE BY CAMERON CALZONI 11/2/1992
!KLG  Put into Vers 6.75.2 DW by KLG July 1992
!MC
!MC     NOTES:  nlayers = NUMBER OF LAYERS OF INTERP DATA(STEP = 0.1)
!MC             ALL ARRAYS BEGIN WITH SUBSCRIPT OF ZERO
!MC             all arrays of data interp to 0.1m have subscript of zero
!MC             referring to depth of 0.1m (Top of first layer)
!MC
!MC                     CHECKED AND O.K.
!     Modified for Lake Tahoe
!     Includes variables for thermal sensitivity analysis
!     Written by Joaquim P. Losada and Geoff Schladow
!     UC-Davis, January 2001
!*******************************************************************	implicit none
		USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER(4)     :: ulkn,uwor,nlayers
		INTEGER(4)     :: i,j,ii,jj,lk,njday,ik
		INTEGER(4)     :: uper_i,lower_i,t_min(1), t_max(1)
		LOGICAL*4 NOPROBLEMS

		REAL(8)	:: wind_speed,print_hsave
		REAL(8)	:: lake_top,lake_bottom
		REAL(8)	:: uper,lower,XPE
		REAL(8)	:: usquared,thermdepth,lakenumber
		REAL(8)	:: xp,zc,xmass, IsoTemp, VolSum, IsoSal, Mass
!		REAL(8) :: IsoMass, IsoDen, IsoVol, VolExtra, ijk
!
!     Definitions for Statistics Analysis
!
      REAL(8)	:: ave_low  ,adev_low  ,sdev_low,var_low,skew_low,curt_low
		REAL(8)	:: ave_up   ,adev_up   ,sdev_up ,var_up ,skew_up ,curt_up
		REAL(8)	:: ave_low_D,adev_low_D,sdev_low_D
		REAL(8)	:: var_low_D,skew_low_D,curt_low_D
		REAL(8)	:: ave_up_D ,adev_up_D ,sdev_up_D
		REAL(8)	:: var_up_D, skew_up_D, curt_up_D

!IF		REAL(8)	:: calc_XMOM
!		REAL(8)	:: Mix_depth_F,Mix_depth_G
		REAL(8), PARAMETER	:: grav = 9.81d0
!		REAL(8) :: AreaTahoe

!		REAL(8), PARAMETER	:: Amax		= 465969.4*1000.0d0
!		REAL(8), PARAMETER	:: DepthMax = 501.45d0
!		REAL(8), PARAMETER	:: Shape	= 0.51d0
!
!     Interpolate density and temperature each 0.1m
!
		CALL INTERPOLATE_LAYER_DATA(nlayers,idepth,density,tempy,salty)

		IF (nlayers.lt.1) THEN
			NOPROBLEMS = .FALSE.
			GOTO 4406
		ELSE
			NOPROBLEMS = .true.
		ENDIF

		wind_speed	= u6x
		IF (wind_speed .lt. 0.05) wind_speed = 0.05

      usquared = 1.612e-6*wind_speed*wind_speed

		xmom = CALC_XMOM(nlayers)

!
!     Store for use in Optima
!
		IF(xmom.lt.0.0d0) THEN
			thermdepth = -99.0
			vector_thermdepth(lk) = -99.0
			vector_thermtemp (lk) = -99.0
			lower_i    = -99.0
			uper_i     = -99.0
			n_low      = -99.0
			adev_low   = -99.0
			adev_up    = -99.0
			adev_low_D = -99.0
			adev_up_D  = -99.0
			lakenumber = -99.0
			n_up       = -99.0
			n_up_D     = -99.0
			n_low_D    = -99.0
			GOTO 4406
		ELSE
			thermdepth = idepth(nlayers-1)-xmom
		ENDIF

		vector_thermdepth(lk) = xmom
		vector_day(lk)        = jday
!
!     Temperature at thermdepth.Used for sensitivity analysis
!
      lower_i    = 0
		uper_i     = 0
      n_low      = 0.0d0
		adev_low   = 0.0d0
		adev_up    = 0.0d0
		adev_low_D = 0.0d0
		adev_up_D  = 0.0d0
      n_up       = 0.0d0
      n_up_D     = 0.0d0
      n_low_D    = 0.0d0

!
!     Case when Lake Number is zero
!
		DO i = 0,nlayers-1
			IF((vector_thermdepth(lk)-idepth(i)).lt.0.1.and.		&
		  		vector_thermdepth(lk).gt.idepth(i))THEN
				lower = tempy(i)
				lower_i = i
			ENDIF

			IF((idepth(i)-vector_thermdepth(lk)).lt.0.1.and.		&
		  		vector_thermdepth(lk).lt.idepth(i))THEN
				uper = tempy(i)
				uper_i = i
			ENDIF
		ENDDO

		IF(abs(uper-lower).lt.0.1) THEN
			vector_thermtemp(lk) = lower
		ELSE
			IF ((idepth(uper_i)-idepth(lower_i)).le.0.0d0) THEN
				vector_thermtemp(lk) = lower
			ELSE
				vector_thermtemp(lk) = lower +(uper-lower)/(idepth(uper_i)-idepth(lower_i))*		&
     					(vector_thermdepth(lk)-idepth(lower_i))
			ENDIF
		ENDIF

		DO i = 0,lower_i
!		DO i = 1,lower_i + 1
			adev_low   = adev_low   + (vector_thermtemp (lk) -tempy(i))**2
			adev_low_D = adev_low_D + (vector_thermdepth(lk)-idepth(i))**2
!			n_low(i)   = tempy(i-1)
!			n_low_D(i) = idepth(i-1)
		ENDDO

		DO i = uper_i,nlayers-1
!		DO i = uper_i,nlayers-1
			adev_up   = adev_up   + (vector_thermtemp (lk) -tempy(i))**2
			adev_up_D = adev_up_D + (vector_thermdepth(lk)-idepth(i))**2
!			n_up(i)   = tempy(i-1)
!			n_up_D(i) = idepth(i-1)
		ENDDO
!
!     Calculate the deviation. # of cases in denominator already
!     account #-1, by adding 1 extra point corresponding to the T mean
!
      adev_low   = sqrt(adev_low   /lower_i)
		adev_low_D = sqrt(adev_low_D /lower_i)

      adev_up   = sqrt(adev_up  /(nlayers-uper_i))
		adev_up_D = sqrt(adev_up_D/(nlayers-uper_i))

!
!     Temperature lower deviation around TermDepth
!
!      call moment(n_low,lower_i+1,ave_low,adev_low,
!     &	        sdev_low,var_low,skew_low,curt_low)
!
!     Temperature upper deviation around TermDepth
!
!    	call moment(n_up,uper_i+1,ave_up,adev_up,
!     &	        sdev_up,var_up,skew_up,curt_up)
!
!     Thermocline Depth lower deviation around TermDepth
!
!      call moment(n_low_D,lower_i+1,ave_low_D,adev_low_D,
!     &	        sdev_low_D,var_low_D,skew_low_d,curt_low_D)
!
!     Thermocline Depth upper deviation around TermDepth
!
!    	call moment(n_up_U,uper_i+1,ave_up_D,adev_up_D,
!     &	        sdev_up_D,var_up_D,skew_up_D,curt_up_D)

8182	CONTINUE

		CALL LNPE3(nlayers,xp,zc,xmass,xpe)

		lake_top   = -xp*(xmass*1e6)*(1.0-((idepth(nlayers-1)-thermdepth)/idepth(nlayers-1)))
		lake_bottom= 1000*usquared*((A((nlayers-1)+1)*1e6)**1.5)*(1.0-(zc/idepth(nlayers-1)))

		IF (lake_top.eq.0.0d0.and.lake_bottom.eq.0.0d0) THEN
			noproblems = .false.
			GOTO 4406
		ENDIF

		IF (lake_bottom.eq.0.0d0) THEN
			noproblems = .false.
			GOTO 4406
		ENDIF

		lakenumber=lake_top/lake_bottom

		IF(lakenumber.lt.0.0d0) lakenumber	= -99.0

4406  CONTINUE

		IF (NOPROBLEMS) THEN
			WRITE(ulkn,4407) jday,lakenumber,depmx,vector_thermdepth(lk),					&
				vector_thermdepth(lk) - adev_low_D,vector_thermdepth(lk) + adev_up_D,   &
				vector_thermtemp (lk), vector_thermtemp (lk) - adev_low,						&
				vector_thermtemp (lk) + adev_up

4407		FORMAT(I8,f8.1,x,7f10.2)

		ELSE
			WRITE(ULKN,4408) jday
4408		FORMAT(I10,'  NaN')
		ENDIF

		RETURN
		END SUBROUTINE LAKENUM


*deck qcomp
      function qcomp(alpha,dfac,n,l,t,xk)
c
c  compute q(n,l) scaled by sqrt(pi)*exp(-t) to prevent overflows
c  arguments are alpha, xk, and t=xk**2/(4*alpha)
c  no restriction on the magnitude of t
c  increase dfac array to raise n, l restrictions
c
      implicit real*8 (a-h,o-z)
      parameter (am1=-1.0d0, a0=0.0d0, accpow=1.0d-14,
     1  accasy=1.0d-10, a1rtpi=0.56418958354775629d0, a1=1.0d0,
     2  a2=2.0d0, a4=4.0d0)
      dimension dfac(*)
      dimension tmin(0:8)
      data tmin/31.0d0,28.0d0,25.0d0,23.0d0,22.0d0,20.0d0,19.0d0,
     1  18.0d0,15.0d0/
c
      if(mod(n+l,2).ne.0.or.n.le.l) go to 30
c
c  use alternating series (n+l.le.22.and.l.le.10)
c
      if(l.eq.0) then
        xkp=a1
      else
        xkp=(xk/(alpha+alpha))**l
      endif
      prefac=xkp * dfac(n+l+1)/
     1  ((alpha+alpha)**((n-l)/2) * sqrt(a4*alpha) * dfac(l+l+3))
      num=l-n+2
      xden=(l+l+3)
      term=a1
      sum=term
      xc=am1
   10 if(num.ne.0) then
        fnum=num
        term=term*fnum*t/(xden*xc)
        xc=xc+am1
        sum=sum+term
        num=num+2
        xden=xden+a2
        go to 10
      endif
c
      qcomp=prefac*sum
      return
c
   30 if(t.lt.tmin(min(n,8))) go to 60
c
c  use asymptotic series (arbitrary n,l)
c
      xkp=(xk/(alpha+alpha))**(n-2)
      prefac=xkp/((alpha+alpha)*sqrt(a4*alpha))
      sum=a1
      term=a1
      fac1=(l-n+2)
      fac2=(1-l-n)
      xc=a1
   40 term=term*fac1*fac2/(a4*xc*t)
      if(term.eq.a0) go to 50
      sum=sum+term
      if(abs(term/sum).lt.accasy) go to 50
      fac1=fac1+a2
      fac2=fac2+a2
      xc=xc+a1
      go to 40
   50 qcomp=prefac*sum
      return
c
c  use power series (n+l.le.22.and.l.le.10)
c
   60 if(l.eq.0) then
        xkp=a1
      else
        xkp=(xk/(alpha+alpha))**l
      endif
      prefac=exp(-t)*xkp/(alpha+alpha)**((n-l+1)/2)
      if(mod(n+l,2).eq.0) then
        prefac=prefac/sqrt(a4*alpha)
      else
        prefac=a1rtpi*prefac
      endif
      xnum=(l+n-1)
      xden=(l+l+1)
      term=dfac(l+n+1)/dfac(l+l+3)
      sum=term
      xj=a0
   70 xnum=xnum+a2
      xden=xden+a2
      xj=xj+a1
      term=term*t*xnum/(xj*xden)
      sum=sum+term
      if((term/sum).gt.accpow) go to 70
      qcomp=prefac*sum
      return
      end


      SUBROUTINE CBALOD4
C
C CHANGE RECORD
C **  SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
C
C **  CALCULATE MOMENTUM AND ENERGY DISSIPATION
C
      DO L=2,LA
        LN=LNC(L)
        UUEOUTO=UUEOUTO+0.5*SPB(L)*DXYP(L)*(U(L,1)*TBX(L)
     &      +U(LEAST(L),1)*TBX(LEAST(L))
     &      -U(L,KC)*TSX(L)-U(LEAST(L),KC)*TSX(LEAST(L)))
        VVEOUTO=VVEOUTO+0.5*SPB(L)*DXYP(L)*(V(L,1)*TBY(L)+V(LN,1)*
     &       TBX(LN)-V(L,KC)*TSY(L)-V(LN,KC)*TSX(LN))
      ENDDO
      DO K=1,KS
        DO L=2,LA
          LN=LNC(L)
          DUTMP=0.5*( U(L,K+1)+U(LEAST(L),K+1)-U(L,K)-U(LEAST(L),K) )
          DVTMP=0.5*( V(L,K+1)+V(LN,K+1)-V(L,K)-V(LN,K) )
          UUEOUTO=UUEOUTO+SPB(L)*2.0*DXYP(L)*AV(L,K)
     &        *( DUTMP*DUTMP )/(DZC(K+1)+DZC(K))
          VVEOUTO=VVEOUTO+SPB(L)*2.0*DXYP(L)*AV(L,K)
     &        *( DVTMP*DVTMP )/(DZC(K+1)+DZC(K))
          BBEOUTO=BBEOUTO+SCB(L)*DXYP(L)*HP(L)
     &        *GP*AB(L,K)*(B(L,K+1)-B(L,K))
        ENDDO
      ENDDO
      RETURN
      END