module mod_mdct
    use kind_m
    implicit none
    private
    public :: mdct_initialize, sub_mdct
    real (kind = kd), parameter::c(0:7) = (/ -0.6000_kd, -0.5350_kd, -0.3300_kd, -0.1850_kd, &
                                             -0.0950_kd, -0.0410_kd, -0.0142_kd, -0.0037_kd  /)
    integer, save :: indx9(9)
    complex (kind = kd), save:: omega9(0:8), omega9s(9), sqrt3_2, omega3(0:2), omega3s(3)
    real (kind = kd), save :: ca(0:7), cs(0:7), window_n(36), window_s(12), window_start(36), window_stop(36)
    real (kind = kd), save, allocatable :: subbuff(:, :, :)
    real (kind = kd), save :: pi
contains
!---------------------------------------------------------------------------------------------
    subroutine mdct_initialize()
        integer :: i
        pi = 4.0_kd * atan(1.0_kd)
        subbuff = 0.0_kd
        call fft9_initialize()
        call fft3_initialize()
        ! iso table b.9 coefficients for aliasing reduction:
        do i = 0, 7
            cs(i) =  sqrt( 1.0_kd   / ( 1.0_kd + c(i)**2 ) )
            ca(i) = -sqrt( c(i)**2  / ( 1.0_kd + c(i)**2 ) )
        end do
        ! iso 2.4.3.4.10.3 windowing, c.1.5.3.3
        ! normal window
        do i = 1, 36
            window_n(i) = sin( real(2 * i - 1, kind = kd) / 72.0_kd * pi)
        end do
        ! short window
        do i = 1, 12
            window_s(i) = sin( real(2 * i - 1, kind = kd) / 24.0_kd * pi)
        end do
        ! start / stop window
        do i = 1, 18
            window_start(i     ) = sin( real(2 *  i       - 1, kind = kd) / 72.0_kd * pi)
            window_stop (i + 18) = sin( real(2 * (i + 18) - 1, kind = kd) / 72.0_kd * pi)
        end do
        do i = 1, 6
            window_start(i + 24) = sin( real(2 * (i + 6) - 1, kind = kd) / 24.0_kd * pi)
            window_stop (i +  6) = sin( real(2 *  i      - 1, kind = kd) / 24.0_kd * pi)
        end do
        window_start(19:24) = 1.0_kd
        window_start(31:36) = 0.0_kd
        window_stop ( 1: 6) = 0.0_kd
        window_stop (13:18) = 1.0_kd
    end subroutine mdct_initialize
!-------------------------------------------------------------------------------------------------
    subroutine cp_subband(subband, subbuff)
        real (kind = kd), intent(in ) :: subband(:, :, :) ! 32 * 36 * nchannel
        real (kind = kd), intent(out) :: subbuff(:, :, :) ! 32 * 54 * nchannel
        subbuff = eoshift(subbuff, 36, 0.0_kd, 2)
        subbuff(:     , 19:54  , :) =  subband(:, :, :)            ! C.1.5.3.3  ! ISO 2.4.3.4.10.5
        subbuff(2:32:2, 20:54:2, :) = -subbuff(2:32:2, 20:54:2, :) ! ISO figure A.4 layer III decoder diagram
    end subroutine cp_subband
!--------------------------------------------------------------------------------------------------
    subroutine sub_mdct(subband, r_mdct, mblock_type, q_alias)
        real (kind = kd), intent(in ) :: subband(:, :, :)
        real (kind = kd), intent(out) :: r_mdct (:, :, :, :)
        integer         , intent(in ) :: mblock_type(:, :)
        logical         , intent(in ) :: q_alias
        integer :: igranule, ichannel
        logical, save :: qfirst = .true.
        if (qfirst) then
            qfirst = .false.
            allocate( subbuff(32, 54, size(subband, 3)) )
            subbuff = 0.0_kd
            call mdct_initialize()
        end if
        call cp_subband(subband, subbuff)
        do ichannel = 1, size(subband, 3)
            do igranule = 1, 2
                select case (mblock_type(igranule, ichannel))
                case ( 0) ! long block
                    call sub_mdct_normal(igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call anti_alias(r_mdct(1:32, :, igranule, ichannel))
                case (10) ! start block : long -> short
                    call sub_mdct_start (igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call anti_alias(r_mdct(1:32, :, igranule, ichannel))
                case (11) ! start block : long -> mixed
                    call sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call sub_mdct_start (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call anti_alias(r_mdct(1:32, :, igranule, ichannel))
                case (30) ! stop block : short -> long
                    call sub_mdct_stop  (igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call anti_alias(r_mdct(1:32, :, igranule, ichannel))
                case (31) ! stop block : mixed -> long
                    call sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call sub_mdct_stop  (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call anti_alias(r_mdct(1:32, :, igranule, ichannel))
                case (20) ! short block : short mode
                    call sub_mdct_short(igranule, 1, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                case (21) ! short block : mixed mode
                    call sub_mdct_normal(igranule, 1,  2, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    call sub_mdct_short (igranule, 3, 32, subbuff(:, :, ichannel), r_mdct(:, :, igranule, ichannel))
                    if (q_alias) call anti_alias(r_mdct(1:2, :, igranule, ichannel))
                case default
                    stop 'error : subroutine sub_mdct : block_type error'
                end select
            end do
        end do
    end subroutine sub_mdct
!--------------------------------------------------------------------------------------------------
    subroutine sub_mdct_normal(igranule, n0, n1, subbuff, r_mdct)
        integer         , intent(in ) :: igranule, n0, n1
        real (kind = kd), intent(in ) :: subbuff(:, :)
        real (kind = kd), intent(out) :: r_mdct (:, :)
        real (kind = kd)              :: wk(36)
        integer :: iband, k
        k = 18 * (igranule - 1) + 1
        do iband = n0, n1
            wk = window_n * subbuff(iband, k:k + 35)
            call mdct36(wk, r_mdct(iband, :))
        end do
    end subroutine sub_mdct_normal
!--------------------------------------------------------------------------------------------------
    subroutine sub_mdct_start(igranule, n0, n1, subbuff, r_mdct)
        integer         , intent(in ) :: igranule, n0, n1
        real (kind = kd), intent(in ) :: subbuff(:, :)
        real (kind = kd), intent(out) :: r_mdct (:, :)
        real (kind = kd)              :: wk(36)
        integer :: iband, k
        k = 18 * (igranule - 1) + 1
        do iband = n0, n1
            wk = window_start * subbuff(iband, k:k + 35)
            call mdct36(wk, r_mdct(iband, :))
        end do
    end subroutine sub_mdct_start
!--------------------------------------------------------------------------------------------------
    subroutine sub_mdct_stop(igranule, n0, n1, subbuff, r_mdct)
        integer         , intent(in ) :: igranule, n0, n1
        real (kind = kd), intent(in ) :: subbuff(:, :)
        real (kind = kd), intent(out) :: r_mdct (:, :)
        real (kind = kd)              :: wk(36)
        integer :: iband, k
        k = 18 * (igranule - 1) + 1
        do iband = n0, n1
            wk = window_stop * subbuff(iband, k:k + 35)
            call mdct36(wk, r_mdct(iband, :))
        end do
    end subroutine sub_mdct_stop
!--------------------------------------------------------------------------------------------------
    subroutine sub_mdct_short(igranule, n0, n1, subbuff, r_mdct)
        integer        , intent(in ) :: igranule, n0, n1
        real (kind = kd), intent(in ) :: subbuff(:, :)
        real (kind = kd), intent(out) :: r_mdct (:, :)
        real (kind = kd)              :: wk(12)
        integer :: iband, k, m, m0, n
        m0 = 18 * (igranule - 1) + 1 + 6
        do k = 1, 3
            m = m0 + 6 * (k - 1)
            n =  1 + 6 * (k - 1)
            do iband = n0, n1
                wk = window_s * subbuff(iband, m:m + 11)
                call mdct12(wk, r_mdct(iband, n:n + 5))
            end do
        end do
    end subroutine sub_mdct_short
!--------------------------------------------------------------------------------------------------
    subroutine anti_alias(x) ! c.1.5.3.3 aliasing-butterfly, 2.4.3.4.10.1 alias reduction, table b.9
        real (kind = kd), intent(in out) :: x(:, :) ! x(32, 18)
        real (kind = kd) :: tmp1, tmp2
        integer :: iband, k
        do iband = 1, size(x, 1) - 1
            do k = 0, 7
                tmp1 = x(iband    , 18 - k)
                tmp2 = x(iband + 1,  1 + k)
                x(iband    , 18 - k) =  tmp1 * cs(k) + tmp2 * ca(k)
                x(iband + 1,  1 + k) =  tmp2 * cs(k) - tmp1 * ca(k)
            end do
        end do
    end subroutine anti_alias
!--------------------------------------------------------------------------------------------------
    subroutine mdct36(x_in, x_out) ! iso c.1.5.3.3 mdct:   ! mdct(4n) <=> fft(n) proof: http://members.at.infoseek.co.jp/kitaurawa/mdct.pdf   (jp)
        real (kind = kd), intent(in ) :: x_in (:) ! 36
        real (kind = kd), intent(out) :: x_out(:) ! 18
        real (kind = kd):: x_shift(36), x_re, x_im
        complex (kind = kd):: fft(9)
        integer:: i
        x_shift( 1: 9) = -x_in(28:36)
        x_shift(10:36) =  x_in( 1:27)
        do i = 1, 9
            x_re = x_shift(2 * i -  1) - x_shift(38 - 2 * i)
            x_im = x_shift(2 * i + 17) - x_shift(20 - 2 * i)
            fft(i) = cmplx(x_re, x_im, kind = kd) * omega9s(i)
        end do
        call fft9(fft)
        fft = fft * omega9s
        do i = 1, 9
            x_out(2 * i - 1) =  real(      fft(i)      , kind = kd)
            x_out(2 * i    ) =  real(aimag(fft(10 - i)), kind = kd)
        end do
    end subroutine mdct36
!---------------------------------------------------------------------------------------------------
    subroutine fft9(fft) ! fft of 3^n (n=2)
        complex (kind = kd), intent(in out) :: fft(:)
        complex (kind = kd) :: c1, c2, c3, c4, tmp1, tmp2, tmp3
        integer, parameter :: nn = 9
        integer :: i, j, iphase1, iphase2, m1, m2, m3, k3, kn3
        fft = fft(indx9) / 9.0_kd ! reorder and normalize
        do k3 = 1, 2 ! 3^n (n=2)
            kn3 = 3**(k3 - 1)
            do i = 1, nn, 3 * kn3
                do j = 1, kn3
                    iphase1 = 3**(2 - k3) * (j - 1)
                    iphase2 = 2 * iphase1
                    c1 = omega9( mod(iphase1, nn) )
                    c2 = omega9( mod(iphase2, nn) )
                    m1 = i + j - 1
                    m2 = m1 + kn3
                    m3 = m2 + kn3
                    tmp1 =      fft(m1)
                    tmp2 = c1 * fft(m2)
                    tmp3 = c2 * fft(m3)
                    fft(m1) = tmp1 + tmp2 + tmp3
                    c3 = tmp1 - 0.5_kd * ( tmp2 + tmp3 )
                    c4 =      sqrt3_2  * ( tmp2 - tmp3 ) ! sqrt3_2 = i sqrt(3) / 2
                    fft(m2) = c3 + c4
                    fft(m3) = c3 - c4
                end do
            end do
        end do
    end subroutine fft9
!-----------------------------------------------------------------------
    subroutine fft9_initialize()
        integer :: i, j, k, n
        pi = 4.0_kd * atan(1.0_kd)
        sqrt3_2 = cmplx(0.0_kd, sqrt(0.75_kd), kind = kd) ! isqrt(3) / 2
        do i = 1, 9
            n = 0
            k = i - 1
            do j = 2 - 1, 0, -1
                n = n + mod(k, 3) * 3**j
                k = k / 3
            end do
            indx9(i) = n + 1
            omega9(i - 1) = exp( cmplx(0.0_kd, 2.0_kd * pi /  9.0_kd * real(i - 1, kind = kd), kind = kd) )
            omega9s(i)    = exp( cmplx(0.0_kd, 2.0_kd * pi / 36.0_kd * ( 1.0_kd / 8.0_kd + real(i - 1, kind = kd) ), kind = kd) )
        end do
    end subroutine fft9_initialize
!-----------------------------------------------------------------------
    subroutine mdct12(x_in, x_out)
        real (kind = kd), intent(in ) :: x_in (:) ! 12
        real    (kind = kd), intent(out) :: x_out(:) !  6
        real    (kind = kd):: x_shift(12), x_re, x_im
        complex (kind = kd):: fft(3)
        integer:: i
        x_shift( 1: 3) = -x_in(10:12)
        x_shift( 4:12) =  x_in( 1: 9)
        do i = 1, 3
            x_re = x_shift(2 * i - 1) - x_shift(14 - 2 * i)
            x_im = x_shift(2 * i + 5) - x_shift( 8 - 2 * i)
            fft(i) = cmplx(x_re, x_im, kind = kd) * omega3s(i)
        end do
        call fft3(fft)
        fft = fft * omega3s
        do i = 1, 3
            x_out(2 * i - 1) =  real(      fft(i)     , kind = kd)
            x_out(2 * i    ) =  real(aimag(fft(4 - i)), kind = kd)
        end do
    end subroutine mdct12
!-----------------------------------------------------------------------
    subroutine fft3(fft)
        complex (kind = kd), intent(in out):: fft(:)
        complex (kind = kd) :: c2, c3, c4
        c2 = fft(2) + fft(3)
        c3 = fft(1) - 0.5_kd * c2
        c4 = sqrt3_2 * ( fft(2) - fft(3) ) ! sqrt3_2 = i sqrt(3) / 2
        fft(1) = fft(1) + c2
        fft(2) = c3 + c4
        fft(3) = c3 - c4
        fft = fft / 3.0_kd ! normalization
    end subroutine fft3
!--------------------------------------------------------------------------------------------------
    subroutine fft3_initialize()
        integer :: i
        pi = 4.0_kd * atan(1.0_kd)
        sqrt3_2 = cmplx(0.0_kd, sqrt(0.75_kd), kind = kd) ! isqrt(3) / 2
        do i = 1, 3
            omega3(i - 1) = exp( cmplx(0.0_kd, 2.0_kd * pi /  3.0_kd * real(i - 1, kind = kd), kind = kd) )
            omega3s(i)    = exp( cmplx(0.0_kd, 2.0_kd * pi / 12.0_kd * ( 1.0_kd / 8.0_kd + real(i - 1, kind = kd) ), kind = kd) )
        end do
    end subroutine fft3_initialize
!-----------------------------------------------------------------------
end module mod_mdct


*> \brief \b SBDSDC
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SBDSDC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
*                          WORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          COMPQ, UPLO
*       INTEGER            INFO, LDU, LDVT, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IQ( * ), IWORK( * )
*       REAL               D( * ), E( * ), Q( * ), U( LDU, * ),
*      $                   VT( LDVT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SBDSDC computes the singular value decomposition (SVD) of a real
*> N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
*> using a divide and conquer method, where S is a diagonal matrix
*> with non-negative diagonal elements (the singular values of B), and
*> U and VT are orthogonal matrices of left and right singular vectors,
*> respectively. SBDSDC can be used to compute all singular values,
*> and optionally, singular vectors or singular vectors in compact form.
*>
*> This code makes very mild assumptions about floating point
*> arithmetic. It will work on machines with a guard digit in
*> add/subtract, or on those binary machines without guard digits
*> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
*> It could conceivably fail on hexadecimal or decimal machines
*> without guard digits, but we know of none.  See SLASD3 for details.
*>
*> The code currently calls SLASDQ if singular values only are desired.
*> However, it can be slightly modified to compute singular values
*> using the divide and conquer method.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  B is upper bidiagonal.
*>          = 'L':  B is lower bidiagonal.
*> \endverbatim
*>
*> \param[in] COMPQ
*> \verbatim
*>          COMPQ is CHARACTER*1
*>          Specifies whether singular vectors are to be computed
*>          as follows:
*>          = 'N':  Compute singular values only;
*>          = 'P':  Compute singular values and compute singular
*>                  vectors in compact form;
*>          = 'I':  Compute singular values and singular vectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix B.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          On entry, the n diagonal elements of the bidiagonal matrix B.
*>          On exit, if INFO=0, the singular values of B.
*> \endverbatim
*>
*> \param[in,out] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          On entry, the elements of E contain the offdiagonal
*>          elements of the bidiagonal matrix whose SVD is desired.
*>          On exit, E has been destroyed.
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is REAL array, dimension (LDU,N)
*>          If  COMPQ = 'I', then:
*>             On exit, if INFO = 0, U contains the left singular vectors
*>             of the bidiagonal matrix.
*>          For other values of COMPQ, U is not referenced.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= 1.
*>          If singular vectors are desired, then LDU >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] VT
*> \verbatim
*>          VT is REAL array, dimension (LDVT,N)
*>          If  COMPQ = 'I', then:
*>             On exit, if INFO = 0, VT**T contains the right singular
*>             vectors of the bidiagonal matrix.
*>          For other values of COMPQ, VT is not referenced.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>          The leading dimension of the array VT.  LDVT >= 1.
*>          If singular vectors are desired, then LDVT >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDQ)
*>          If  COMPQ = 'P', then:
*>             On exit, if INFO = 0, Q and IQ contain the left
*>             and right singular vectors in a compact form,
*>             requiring O(N log N) space instead of 2*N**2.
*>             In particular, Q contains all the REAL data in
*>             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
*>             words of memory, where SMLSIZ is returned by ILAENV and
*>             is equal to the maximum size of the subproblems at the
*>             bottom of the computation tree (usually about 25).
*>          For other values of COMPQ, Q is not referenced.
*> \endverbatim
*>
*> \param[out] IQ
*> \verbatim
*>          IQ is INTEGER array, dimension (LDIQ)
*>          If  COMPQ = 'P', then:
*>             On exit, if INFO = 0, Q and IQ contain the left
*>             and right singular vectors in a compact form,
*>             requiring O(N log N) space instead of 2*N**2.
*>             In particular, IQ contains all INTEGER data in
*>             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
*>             words of memory, where SMLSIZ is returned by ILAENV and
*>             is equal to the maximum size of the subproblems at the
*>             bottom of the computation tree (usually about 25).
*>          For other values of COMPQ, IQ is not referenced.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          If COMPQ = 'N' then LWORK >= (4 * N).
*>          If COMPQ = 'P' then LWORK >= (6 * N).
*>          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (8*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  The algorithm failed to compute a singular value.
*>                The update process of divide and conquer failed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2016
*
*> \ingroup auxOTHERcomputational
*
*> \par Contributors:
*  ==================
*>
*>     Ming Gu and Huan Ren, Computer Science Division, University of
*>     California at Berkeley, USA
*>
*  =====================================================================
      SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
     $                   WORK, IWORK, INFO )
*
*  -- LAPACK computational routine (version 3.7.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2016
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, UPLO
      INTEGER            INFO, LDU, LDVT, N
*     ..
*     .. Array Arguments ..
      INTEGER            IQ( * ), IWORK( * )
      REAL               D( * ), E( * ), Q( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
*  =====================================================================
*  Changed dimension statement in comment describing E from (N) to
*  (N-1).  Sven, 17 Feb 05.
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
     $                   ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
     $                   MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
     $                   SMLSZP, SQRE, START, WSTART, Z
      REAL               CS, EPS, ORGNRM, P, R, SN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH, SLANST
      EXTERNAL           SLAMCH, SLANST, ILAENV, LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLARTG, SLASCL, SLASD0, SLASDA, SLASDQ,
     $                   SLASET, SLASR, SSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL, ABS, INT, LOG, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IUPLO = 0
      IF( LSAME( UPLO, 'U' ) )
     $   IUPLO = 1
      IF( LSAME( UPLO, 'L' ) )
     $   IUPLO = 2
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ICOMPQ = 0
      ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ICOMPQ = 2
      ELSE
         ICOMPQ = -1
      END IF
      IF( IUPLO.EQ.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPQ.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
     $         N ) ) ) THEN
         INFO = -7
      ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
     $         N ) ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SBDSDC', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
      SMLSIZ = ILAENV( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
      IF( N.EQ.1 ) THEN
         IF( ICOMPQ.EQ.1 ) THEN
            Q( 1 ) = SIGN( ONE, D( 1 ) )
            Q( 1+SMLSIZ*N ) = ONE
         ELSE IF( ICOMPQ.EQ.2 ) THEN
            U( 1, 1 ) = SIGN( ONE, D( 1 ) )
            VT( 1, 1 ) = ONE
         END IF
         D( 1 ) = ABS( D( 1 ) )
         RETURN
      END IF
      NM1 = N - 1
*
*     If matrix lower bidiagonal, rotate to be upper bidiagonal
*     by applying Givens rotations on the left
*
      WSTART = 1
      QSTART = 3
      IF( ICOMPQ.EQ.1 ) THEN
         CALL SCOPY( N, D, 1, Q( 1 ), 1 )
         CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 )
      END IF
      IF( IUPLO.EQ.2 ) THEN
         QSTART = 5
         IF( ICOMPQ .EQ. 2 ) WSTART = 2*N - 1
         DO 10 I = 1, N - 1
            CALL SLARTG( D( I ), E( I ), CS, SN, R )
            D( I ) = R
            E( I ) = SN*D( I+1 )
            D( I+1 ) = CS*D( I+1 )
            IF( ICOMPQ.EQ.1 ) THEN
               Q( I+2*N ) = CS
               Q( I+3*N ) = SN
            ELSE IF( ICOMPQ.EQ.2 ) THEN
               WORK( I ) = CS
               WORK( NM1+I ) = -SN
            END IF
   10    CONTINUE
      END IF
*
*     If ICOMPQ = 0, use SLASDQ to compute the singular values.
*
      IF( ICOMPQ.EQ.0 ) THEN
*        Ignore WSTART, instead using WORK( 1 ), since the two vectors
*        for CS and -SN above are added only if ICOMPQ == 2,
*        and adding them exceeds documented WORK size of 4*n.
         CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
     $                LDU, WORK( 1 ), INFO )
         GO TO 40
      END IF
*
*     If N is smaller than the minimum divide size SMLSIZ, then solve
*     the problem with another solver.
*
      IF( N.LE.SMLSIZ ) THEN
         IF( ICOMPQ.EQ.2 ) THEN
            CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
            CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
            CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
     $                   LDU, WORK( WSTART ), INFO )
         ELSE IF( ICOMPQ.EQ.1 ) THEN
            IU = 1
            IVT = IU + N
            CALL SLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
     $                   N )
            CALL SLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
     $                   N )
            CALL SLASDQ( 'U', 0, N, N, N, 0, D, E,
     $                   Q( IVT+( QSTART-1 )*N ), N,
     $                   Q( IU+( QSTART-1 )*N ), N,
     $                   Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
     $                   INFO )
         END IF
         GO TO 40
      END IF
*
      IF( ICOMPQ.EQ.2 ) THEN
         CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
         CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
      END IF
*
*     Scale.
*
      ORGNRM = SLANST( 'M', N, D, E )
      IF( ORGNRM.EQ.ZERO )
     $   RETURN
      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
      CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
*
      EPS = SLAMCH( 'Epsilon' )
*
      MLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
      SMLSZP = SMLSIZ + 1
*
      IF( ICOMPQ.EQ.1 ) THEN
         IU = 1
         IVT = 1 + SMLSIZ
         DIFL = IVT + SMLSZP
         DIFR = DIFL + MLVL
         Z = DIFR + MLVL*2
         IC = Z + MLVL
         IS = IC + 1
         POLES = IS + 1
         GIVNUM = POLES + 2*MLVL
*
         K = 1
         GIVPTR = 2
         PERM = 3
         GIVCOL = PERM + MLVL
      END IF
*
      DO 20 I = 1, N
         IF( ABS( D( I ) ).LT.EPS ) THEN
            D( I ) = SIGN( EPS, D( I ) )
         END IF
   20 CONTINUE
*
      START = 1
      SQRE = 0
*
      DO 30 I = 1, NM1
         IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
*
*        Subproblem found. First determine its size and then
*        apply divide and conquer on it.
*
            IF( I.LT.NM1 ) THEN
*
*        A subproblem with E(I) small for I < NM1.
*
               NSIZE = I - START + 1
            ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
*
*        A subproblem with E(NM1) not too small but I = NM1.
*
               NSIZE = N - START + 1
            ELSE
*
*        A subproblem with E(NM1) small. This implies an
*        1-by-1 subproblem at D(N). Solve this 1-by-1 problem
*        first.
*
               NSIZE = I - START + 1
               IF( ICOMPQ.EQ.2 ) THEN
                  U( N, N ) = SIGN( ONE, D( N ) )
                  VT( N, N ) = ONE
               ELSE IF( ICOMPQ.EQ.1 ) THEN
                  Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
                  Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
               END IF
               D( N ) = ABS( D( N ) )
            END IF
            IF( ICOMPQ.EQ.2 ) THEN
               CALL SLASD0( NSIZE, SQRE, D( START ), E( START ),
     $                      U( START, START ), LDU, VT( START, START ),
     $                      LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
            ELSE
               CALL SLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
     $                      E( START ), Q( START+( IU+QSTART-2 )*N ), N,
     $                      Q( START+( IVT+QSTART-2 )*N ),
     $                      IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
     $                      N ), Q( START+( DIFR+QSTART-2 )*N ),
     $                      Q( START+( Z+QSTART-2 )*N ),
     $                      Q( START+( POLES+QSTART-2 )*N ),
     $                      IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
     $                      N, IQ( START+PERM*N ),
     $                      Q( START+( GIVNUM+QSTART-2 )*N ),
     $                      Q( START+( IC+QSTART-2 )*N ),
     $                      Q( START+( IS+QSTART-2 )*N ),
     $                      WORK( WSTART ), IWORK, INFO )
            END IF
            IF( INFO.NE.0 ) THEN
               RETURN
            END IF
            START = I + 1
         END IF
   30 CONTINUE
*
*     Unscale
*
      CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
   40 CONTINUE
*
*     Use Selection Sort to minimize swaps of singular vectors
*
      DO 60 II = 2, N
         I = II - 1
         KK = I
         P = D( I )
         DO 50 J = II, N
            IF( D( J ).GT.P ) THEN
               KK = J
               P = D( J )
            END IF
   50    CONTINUE
         IF( KK.NE.I ) THEN
            D( KK ) = D( I )
            D( I ) = P
            IF( ICOMPQ.EQ.1 ) THEN
               IQ( I ) = KK
            ELSE IF( ICOMPQ.EQ.2 ) THEN
               CALL SSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
               CALL SSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
            END IF
         ELSE IF( ICOMPQ.EQ.1 ) THEN
            IQ( I ) = I
         END IF
   60 CONTINUE
*
*     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
*
      IF( ICOMPQ.EQ.1 ) THEN
         IF( IUPLO.EQ.1 ) THEN
            IQ( N ) = 1
         ELSE
            IQ( N ) = 0
         END IF
      END IF
*
*     If B is lower bidiagonal, update U by those Givens rotations
*     which rotated B to be upper bidiagonal
*
      IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
     $   CALL SLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
*
      RETURN
*
*     End of SBDSDC
*
      END


	FUNCTION PLANCK(WAVE,TEMP)
C
C       4/27/99    rea  Update radiation constants.
C
C---------------------------------------------------------
C    Calculate the Spectral Radiance with Planck's Law
C----------------------------------------------------------
	Parameter(C1=3.741775E-16,C2=0.01438769,PI=3.14159265,
     +            FACT=1.0E-6)
C
	IF (TEMP.GT.0.0) THEN
	  WV=WAVE*FACT			!Convert um to m
 	  A=PI*(WV**5.)
	  B=EXP(C2/(WV*TEMP))
	  P=C1/(A*(B-1.0))
	  PLANCK=P*FACT			!Convert 1/m to 1/um
	ELSE
	  PLANCK=0.0
	END IF
	Return
	End


C-----------------------------------------------------------------------
C This is not the original program!
C
C This file was modified by Matteo Frigo to name the common block containing
C X and Y.  See morris.f.orig for the original program.
C
C-----------------------------------------------------------------------

C-----------------------------------------------------------------------
C
C MAIN PROGRAM: TIME-EFFICIENT RADIX-4 FAST FOURIER TRANSFORM
C AUTHOR:       L. ROBERT MORRIS
C               DEPARTMENT OF SYSTEMS AND COMPUTER ENGINEERING
C               CARLETON UNIVERSITY, OTTAWA, CANADA K1S 5B6
C
C INPUT:        THE ARRAYS "X,Y" CONTAINS THE Re, Im PARTS OF THE
C               DATA TO BE TRANSFORMED
C-----------------------------------------------------------------------
        SUBROUTINE FFT4(N,M)
        INTEGER KV1(5),KV2(5)
        COMMON /AA/X(1024),Y(1024),TR(2295)
        DATA KV1/1,4,16,64,256/
        DATA KV2/3,12,48,192,768/
        DATA C21/0.707106778/
        DATA CM/-1.414213563/
        N2=N
        KKINC = 9
C       ------------MAIN FFT LOOPS---------------------------
        DO 10 K=1, M
          N1 = N2
          N2 = N2/4
          N3 = N2 + N2
          N4 = N3 + N2
          JT = N2/2 + 1
C       ------------SPECIAL BUTTERFLY FOR W = 1 --------------
          DO 1 I=1, N, N1
             T1        = X(I)      + X(I + N3)
             R         = X(I)      - X(I + N3)
             T2        = X(I + N2) + X(I + N4)
             X(I)      = T1        + T2
             X(I + N3) = T1        - T2
C
             T1        = Y(I)      + Y(I + N3)
             S         = Y(I)      - Y(I + N3)
             T2        = Y(I + N2) + Y(I + N4)
             Y(I)      = T1        + T2
             Y(I + N3) = T1        - T2
C
             T1        = Y(I + N2) - Y(I + N4)
             T2        = X(I + N2) - X(I + N4)
C
             X(I + N2) = R         + T1
             X(I + N4) = R         - T1
             Y(I + N2) = S         - T2
1            Y(I + N4) = S         + T2
C
          IF(K.EQ.M) GOTO 10
          KK = -8
C       ---------------MAIN BUTTERFLIES--------------------
          DO 20 J = 2, N2
             KK = KK + KKINC
             IF(J.EQ.JT) GOTO 50
C       ------------BUTTERFLIES WITH SAME W----------------
          DO 30 I = J, N, N1
             X1        = X(I)      + X(I + N3)
             X2        = X(I)      - X(I + N3)
             T         = X(I + N2) + X(I + N4)
             X(I)      = X1        + T
             X1        = X1        - T
C
             Y1        = Y(I)      + Y(I + N3)
             Y2        = Y(I)      - Y(I + N3)
             T         = Y(I + N2) + Y(I + N4)
             Y(I)      = Y1        + T
             Y1        = Y1        - T
C
             T         = (X1+Y1)*TR(KK + 3)
             X(I + N3) = TR(KK + 4)*Y1 + T
             Y(I + N3) = TR(KK + 5)*X1 + T
C
             T         = Y(I + N2) - Y(I + N4)
             X1        = X2        + T
             X2        = X2        - T
C
             T         = X(I + N2) - X(I + N4)
             Y1        = Y2        - T
             Y2        = Y2        + T
C
             T         = (X1+Y1)*TR(KK)
             X(I + N2) = TR(KK + 1)*Y1 + T
             Y(I + N2) = TR(KK + 2)*X1 + T
C
             T         = (X2+Y2)*TR(KK + 6)
             X(I + N4) = TR(KK + 7)*Y2 + T
30           Y(I + N4) = TR(KK + 8)*X2 + T
C
        GOTO 20
C       --------------SPECIAL BUTTERFLY FOR W = J ------------
50           DO 40 I = J, N, N1
             X1        = X(I)      + X(I + N3)
             X2        = X(I)      - X(I + N3)
             Y1        = Y(I)      + Y(I + N3)
             Y2        = Y(I)      - Y(I + N3)
C
             T         = X(I + N2) + X(I + N4)
             X(I)      = T         + X1
             Y(I+N3)   = T         - X1
C
             T         = Y(I + N2) + Y(I + N4)
             Y(I)      = Y1        + T
             X(I+N3)   = Y1        - T
C
             X1        = X(I + N2) - X(I + N4)
             Y1        = Y(I + N2) - Y(I + N4)
C
             T         = X2        + Y1
             X(I + N2) = (T        - X1  + Y2)*C21
             Y(I + N2) = T*CM      + X(I + N2)
C
             T         = X1        + Y2
             X(I + N4) =(T         - X2  + Y1)*C21
40           Y(I + N4) = T*CM      + X(I + N4)
C
20      CONTINUE
        KKINC = KKINC + KKINC
10      KKINC = KKINC + KKINC
C       --------DIGIT REVERSE COUNTER--------------------
100     J = 1
        NM1 = N - 1
        DO 104 I = 1, NM1
           IF (I.GE.J) GOTO 101
           T    = X(J)
           X(J) = X(I)
           X(I) = T
           T    = Y(J)
           Y(J) = Y(I)
           Y(I) = T
101     INDEX = M
102     IF (KV2(INDEX).GE.J) GOTO 104
103        J = J - KV2(INDEX)
           INDEX = INDEX -1
        IF (KV2(INDEX).LT.J) GOTO 103
104        J = J + KV1(INDEX)
        RETURN
        END
C
        SUBROUTINE INIR4(M)
        COMMON /AA/X(1024),Y(1024),TR(2295)
C
        KK = 1
        N2 = 4**(M-1)
        P = 8.*ATAN(1.0)/FLOAT(4**M)
        DO 20 J = 2,N2
         TR(KK+3) =  COS((2*J-2)*P)
         TR(KK+4) =  SIN((2*J-2)*P)-TR(KK+3)
         TR(KK+5) = -SIN((2*J-2)*P)-TR(KK+3)
         TR(KK)   =  COS((J-1)*P)
         TR(KK+1) =  SIN((J-1)*P)  -TR(KK)
         TR(KK+2) = -SIN((J-1)*P)  -TR(KK)
         TR(KK+6) =  COS((3*J-3)*P)
         TR(KK+7) =  SIN((3*J-3)*P)-TR(KK+6)
         TR(KK+8) = -SIN((3*J-3)*P)-TR(KK+6)
20       KK = KK + 9
        RETURN
        END


      SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C,
     $                   LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR,
     $                   ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL,
     $                   IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the transfer function matrix G of a state-space
C     representation (A,B,C,D) of a linear time-invariant multivariable
C     system, using the pole-zeros method. The transfer function matrix
C     is returned in a minimal pole-zero-gain form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state-space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed to be a zero matrix.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the triplet (A,B,C) as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system (A,B,C,D).  N >= 0.
C
C     M       (input) INTEGER
C             The number of the system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of the system outputs.  P >= 0.
C
C     NPZ     (input) INTEGER
C             The maximum number of poles or zeros of the single-input
C             single-output channels in the system. An upper bound
C             for NPZ is N.  NPZ >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, if EQUIL = 'S', the leading N-by-N part of this
C             array contains the balanced matrix inv(S)*A*S, as returned
C             by SLICOT Library routine TB01ID.
C             If EQUIL = 'N', this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the contents of B are destroyed: all elements but
C             those in the first row are set to zero.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, if EQUIL = 'S', the leading P-by-N part of this
C             array contains the balanced matrix C*S, as returned by
C             SLICOT Library routine TB01ID.
C             If EQUIL = 'N', this array is unchanged on exit.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             If JOBD = 'D', the leading P-by-M part of this array must
C             contain the matrix D.
C             If JOBD = 'Z', the array D is not referenced.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     NZ      (output) INTEGER array, dimension (LDNZ,M)
C             The leading P-by-M part of this array contains the numbers
C             of zeros of the elements of the transfer function
C             matrix G. Specifically, the (i,j) element of NZ contains
C             the number of zeros of the transfer function G(i,j) from
C             the j-th input to the i-th output.
C
C     LDNZ    INTEGER
C             The leading dimension of array NZ.  LDNZ >= max(1,P).
C
C     NP      (output) INTEGER array, dimension (LDNP,M)
C             The leading P-by-M part of this array contains the numbers
C             of poles of the elements of the transfer function
C             matrix G. Specifically, the (i,j) element of NP contains
C             the number of poles of the transfer function G(i,j).
C
C     LDNP    INTEGER
C             The leading dimension of array NP.  LDNP >= max(1,P).
C
C     ZEROSR  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
C             This array contains the real parts of the zeros of the
C             transfer function matrix G. The real parts of the zeros
C             are stored in a column-wise order, i.e., for the transfer
C             functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ...,
C             (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations
C             are reserved for each transfer function, hence, the real
C             parts of the zeros for the (i,j) transfer function
C             are stored starting from the location ((j-1)*P+i-1)*NPZ+1.
C             Pairs of complex conjugate zeros are stored in consecutive
C             memory locations. Note that only the first NZ(i,j) entries
C             are initialized for the (i,j) transfer function.
C
C     ZEROSI  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
C             This array contains the imaginary parts of the zeros of
C             the transfer function matrix G, stored in a similar way
C             as the real parts of the zeros.
C
C     POLESR  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
C             This array contains the real parts of the poles of the
C             transfer function matrix G, stored in the same way as
C             the zeros. Note that only the first NP(i,j) entries are
C             initialized for the (i,j) transfer function.
C
C     POLESI  (output) DOUBLE PRECISION array, dimension (P*M*NPZ)
C             This array contains the imaginary parts of the poles of
C             the transfer function matrix G, stored in the same way as
C             the poles.
C
C     GAINS   (output) DOUBLE PRECISION array, dimension (LDGAIN,M)
C             The leading P-by-M part of this array contains the gains
C             of the transfer function matrix G. Specifically,
C             GAINS(i,j) contains the gain of the transfer function
C             G(i,j).
C
C     LDGAIN  INTEGER
C             The leading dimension of array GAINS.  LDGAIN >= max(1,P).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the
C             controllability of a single-input system (A,b) or (A',c'),
C             where b and c' are columns in B and C' (C transposed). If
C             the user sets TOL > 0, then the given value of TOL is used
C             as an absolute tolerance; elements with absolute value
C             less than TOL are considered neglijible. If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used
C             instead, where EPS is the machine precision (see LAPACK
C             Library routine DLAMCH), and bc denotes the currently used
C             column in B or C' (see METHOD).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, N*(N+P) +
C                              MAX( N + MAX( N,P ), N*(2*N+3)))
C             If N >= P, N >= 1, the formula above can be written as
C             LDWORK >= N*(3*N + P + 3).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the QR algorithm failed to converge when trying to
C                   compute the zeros of a transfer function;
C             = 2:  the QR algorithm failed to converge when trying to
C                   compute the poles of a transfer function.
C                   The errors INFO = 1 or 2 are unlikely to appear.
C
C     METHOD
C
C     The routine implements the pole-zero method proposed in [1].
C     This method is based on an algorithm for computing the transfer
C     function of a single-input single-output (SISO) system.
C     Let (A,b,c,d) be a SISO system. Its transfer function is computed
C     as follows:
C
C     1) Find a controllable realization (Ac,bc,cc) of (A,b,c).
C     2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc).
C     3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)).
C     4) Compute the zeros of (Ao,bo,co,d).
C     5) Compute the gain of (Ao,bo,co,d).
C
C     This algorithm can be implemented using only orthogonal
C     transformations [1]. However, for better efficiency, the
C     implementation in TB04CD uses one elementary transformation
C     in Step 4 and r elementary transformations in Step 5 (to reduce
C     an upper Hessenberg matrix to upper triangular form). These
C     special elementary transformations are numerically stable
C     in practice.
C
C     In the multi-input multi-output (MIMO) case, the algorithm
C     computes each element (i,j) of the transfer function matrix G,
C     for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1
C     is performed once for each value of j (each column of B). The
C     matrices Ac and Ao result in Hessenberg form.
C
C     REFERENCES
C
C     [1] Varga, A. and Sima, V.
C         Numerically Stable Algorithm for Transfer Function Matrix
C         Evaluation.
C         Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable in practice and requires about
C     20*N**3 floating point operations at most, but usually much less.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 2002.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, state-space representation, transfer function, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, C100
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          EQUIL, JOBD
      DOUBLE PRECISION   TOL
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ,
     $                   LDWORK, M, N, NPZ, P
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                   DWORK(*), GAINS(LDGAIN,*), POLESI(*),
     $                   POLESR(*), ZEROSI(*), ZEROSR(*)
      INTEGER            IWORK(*), NP(LDNP,*), NZ(LDNZ,*)
C     .. Local Scalars ..
      DOUBLE PRECISION   ANORM, DIJ, EPSN, MAXRED, TOLDEF
      INTEGER            I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP,
     $                   IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1,
     $                   K, NCONT, WRKOPT
      LOGICAL            DIJNZ, FNDEIG, WITHD
C     .. Local Arrays ..
      DOUBLE PRECISION   Z(1)
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID,
     $                   TB01ZD, TB04BX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      INFO  = 0
      WITHD = LSAME( JOBD, 'D' )
      IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( NPZ.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -14
      ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN
         INFO = -18
      ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN
         INFO = -24
      ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) +
     $                           MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) )
     $       ) THEN
         INFO = -28
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB04CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      DIJ = ZERO
      IF( MIN( N, P, M ).EQ.0 ) THEN
         IF( MIN( P, M ).GT.0 ) THEN
C
            DO 20 J = 1, M
C
               DO 10 I = 1, P
                  NZ(I,J) = 0
                  NP(I,J) = 0
                  IF ( WITHD )
     $               DIJ = D(I,J)
                  GAINS(I,J) = DIJ
   10          CONTINUE
C
   20       CONTINUE
C
         END IF
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Prepare the computation of the default tolerance.
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
         EPSN  = DBLE( N )*DLAMCH( 'Epsilon' )
         ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
      END IF
C
C     Initializations.
C
      IA    = 1
      IC    = IA + N*N
      ITAU  = IC + P*N
      JWORK = ITAU + N
      IAC   = ITAU
C
      K = 1
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      IF( LSAME( EQUIL, 'S' ) ) THEN
C
C        Scale simultaneously the matrices A, B and C:
C        A <- inv(S)*A*S,  B <- inv(S)*B and C <- C*S, where S is a
C        diagonal scaling matrix.
C        Workspace: need   N.
C
         MAXRED = C100
         CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, IERR )
      END IF
C
C     Compute the transfer function matrix of the system (A,B,C,D),
C     in the pole-zero-gain form.
C
      DO 80 J = 1, M
C
C        Save A and C.
C        Workspace: need   W1 = N*(N+P).
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N )
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P )
C
C        Remove the uncontrollable part of the system (A,B(J),C).
C        Workspace: need   W1+N+MAX(N,P);
C                   prefer larger.
C
         CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P,
     $                NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         IF ( J.EQ.1 )
     $      WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1
C
         IB     = IAC   + NCONT*NCONT
         ICC    = IB    + NCONT
         ITAU1  = ICC   + NCONT
         JWK    = ITAU1 + NCONT
         IAS    = ITAU1
         JWORK1 = IAS   + NCONT*NCONT
C
         DO 70 I = 1, P
            IF ( NCONT.GT.0 ) THEN
               IF ( WITHD )
     $            DIJ = D(I,J)
C
C              Form the matrices of the state-space representation of
C              the dual system for the controllable part.
C              Workspace: need   W2 = W1+N*(N+2).
C
               CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N,
     $                      DWORK(IAC), NCONT )
               CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 )
               CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 )
C
C              Remove the unobservable part of the system (A,B(J),C(I)).
C              Workspace: need   W2+2*N;
C                         prefer larger.
C
               CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT,
     $                      DWORK(ICC), DWORK(IB), 1, IP, Z, 1,
     $                      DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1,
     $                      IERR )
               IF ( I.EQ.1 )
     $            WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 )
C
               IF ( IP.GT.0 ) THEN
C
C                 Save the state matrix of the minimal part.
C                 Workspace: need   W3 = W2+N*N.
C
                  CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT,
     $                         DWORK(IAS), IP )
C
C                 Compute the poles of the transfer function.
C                 Workspace: need   W3+N;
C                            prefer larger.
C
                  CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP,
     $                         DWORK(IAC), NCONT, POLESR(K), POLESI(K),
     $                         Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1,
     $                         IERR )
                  IF ( IERR.NE.0 ) THEN
                     INFO = 2
                     RETURN
                  END IF
                  WRKOPT = MAX( WRKOPT,
     $                          INT( DWORK(JWORK1) ) + JWORK1 - 1 )
C
C                 Compute the zeros of the transfer function.
C
                  IPM1   = IP - 1
                  DIJNZ  = WITHD .AND. DIJ.NE.ZERO
                  FNDEIG = DIJNZ .OR. IPM1.GT.0
                  IF ( .NOT.FNDEIG ) THEN
                     IZ = 0
                  ELSE IF ( DIJNZ ) THEN
C
C                    Add the contribution due to D(i,j).
C                    Note that the matrix whose eigenvalues have to
C                    be computed remains in an upper Hessenberg form.
C
                     IZ = IP
                     CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP,
     $                            DWORK(IAC), NCONT )
                     CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1,
     $                           DWORK(IAC), NCONT )
                  ELSE
                     IF( TOL.LE.ZERO )
     $                  TOLDEF = EPSN*MAX( ANORM,
     $                                     DLANGE( 'Frobenius', IP, 1,
     $                                             DWORK(IB), 1, DWORK )
     $                                           )
C
                     DO 30 IM = 1, IPM1
                        IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40
   30                CONTINUE
C
                     IZ = 0
                     GO TO 50
C
   40                CONTINUE
C
C                    Restore (part of) the saved state matrix.
C
                     IZ = IP - IM
                     CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)),
     $                             IP, DWORK(IAC), NCONT )
C
C                    Apply the output injection.
C
                     CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/
     $                           DWORK(IB+IM-1), DWORK(IB+IM), 1,
     $                           DWORK(IAC), NCONT )
                  END IF
C
                  IF ( FNDEIG ) THEN
C
C                    Find the zeros.
C                    Workspace: need   W3+N;
C                               prefer larger.
C
                     CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1,
     $                            IZ, DWORK(IAC), NCONT, ZEROSR(K),
     $                            ZEROSI(K), Z, 1, DWORK(JWORK1),
     $                            LDWORK-JWORK1+1, IERR )
                     IF ( IERR.NE.0 ) THEN
                        INFO = 1
                        RETURN
                     END IF
                  END IF
C
C                 Compute the gain.
C
   50             CONTINUE
                  IF ( DIJNZ ) THEN
                     GAINS(I,J) = DIJ
                  ELSE
                     CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC),
     $                            DWORK(IB), DIJ, POLESR(K), POLESI(K),
     $                            ZEROSR(K), ZEROSI(K), GAINS(I,J),
     $                            IWORK )
                  END IF
                  NZ(I,J) = IZ
                  NP(I,J) = IP
               ELSE
C
C                 Null element.
C
                  NZ(I,J) = 0
                  NP(I,J) = 0
               END IF
C
            ELSE
C
C              Null element.
C
               NZ(I,J) = 0
               NP(I,J) = 0
            END IF
C
            K = K + NPZ
   70    CONTINUE
C
   80 CONTINUE
C
      RETURN
C *** Last line of TB04CD ***
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine objective_peeq(nodeset,istartset,iendset,ialset,
     &  nk,idesvarc,iobject,mi,g0,nobject,epn,objectset,expks)
!
!     calculates the sum of the square of the von Mises stress of a node
!     set
!
      implicit none
!
      character*81 objectset(5,*)
!
      integer nk,istartset(*),iendset(*),ialset(*),nodeset,
     &  idesvarc,iobject,mi(*),j,k,nobject,idesvar
!
      real*8 g0(nobject),epn(*),p,rho,xpeeq,argument,expks
!
      idesvar=idesvarc+1
!
!     calculates the Kreisselmeier-Steinhauser function for the
!     equivalent plastic strain
!
      read(objectset(2,iobject)(41:60),'(f20.0)') rho
      read(objectset(2,iobject)(61:80),'(f20.0)') xpeeq
!
      g0(iobject)=0.d0
!
!     check for the existence of a set, else take the complete mesh
!
      if(nodeset.eq.0) then
         do j=1,nk
            argument=rho*epn(j)/xpeeq
            if(argument.gt.600.d0) then
               write(*,*) '*ERROR in objective_stress: argument'
               write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
               write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
               write(*,*) '       coefficients'
               call exit(201)
            endif
            g0(iobject)=g0(iobject)+dexp(argument)
         enddo
         expks=g0(iobject)
         g0(iobject)=dlog(g0(iobject))/rho
      else
         do j=istartset(nodeset),iendset(nodeset)
            if(ialset(j).gt.0) then
               k=ialset(j)
               argument=rho*epn(k)/xpeeq
               if(argument.gt.600.d0) then
                  write(*,*) '*ERROR in objective_stress: argument'
                  write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
                  write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
                  write(*,*) '       coefficients'
                  call exit(201)
               endif
               g0(iobject)=g0(iobject)+dexp(argument)
            else
               k=ialset(j-2)
               do
                  k=k-ialset(j)
                  if(k.ge.ialset(j-1)) exit
                  argument=rho*epn(k)/xpeeq
                  if(argument.gt.600.d0) then
                     write(*,*) '*ERROR in objective_stress: argument'
                     write(*,*) '       ',argument,
     &               ' of exponential function is too big;'
                     write(*,*)
     &             '       choose other Kreisselmeier-Steinhauser'
                     write(*,*) '       coefficients'
                     call exit(201)
                  endif
                  g0(iobject)=g0(iobject)+dexp(argument)
               enddo
            endif
         enddo
         expks=g0(iobject)
         g0(iobject)=dlog(g0(iobject))/rho
      endif
!
      return
      end


!=================================================
! SUBROUTINES
!	LL2XY(alati,along,lc_x,lc_y,ind, lc_lat0,lc_lng0,i_trans)
!	ROTATE(u,v,ut,vt,iab,ind, rot_phi,rot_dlt)
!
!=================================================

module mod_trans

	implicit none

contains
!==========
subroutine LL2XY(alati,along,lc_x,lc_y,ind, lc_lat0,lc_lng0,i_trans)

	implicit none
!		(lc_lat0,lc_lng0,i_trans) = (Alat0,Alng0,Icord) in CTP ローカル座標中心
!		(X,Y) TO (ALATI,ALONG) IF IND.EQ.1
!		(ALATI,ALONG) TO (X,Y) IF IND.EQ.0
!		local orgin is (lc_lat0, lc_lng0)
!		i_trans(=ICORD) /= 0;  NO CHANGE IN TRANSFORMATION BETWEEN (X,Y) AND (ALATI,ALONG).

	real(8), intent(inout) :: alati, along, lc_x, lc_y
	integer, intent(in) :: ind
	real(8), intent(in) :: lc_lat0, lc_lng0
	integer, intent(in) :: i_trans

	real(8), parameter :: pi = 3.14159265358979324d0

	real(8) :: a, e2, e12, d, rd
	real(8) :: rlat0, slat0, clat0, rlat, slat, clat
	real(8) :: r, an, al, v2, c1, c2, ph1, rph1, rph2, tphi1, cphi1, sphi1, sphi2

! IAU-64 (理科年表2001年に掲載) の場合?
!	a   = 6.378160d3	! 地球の赤道半径
!	e2  = 6.6944541d-3	! 離心率の2乗
!	! 扁平率 1/f = 298.25 とした場合の e^2 = 0.00669454185 のタイプミス？
!	e12 = 6.7395719d-3	!

! WGS-84 の場合
	a   = 6.37813700000000d3	! 地球の赤道半径 km
	e2  = 6.69438002301275d-3	! 離心率の2乗
	e12 = e2 / (1.d0 - e2)

	d   = 180.d0/pi		! radian <--> degree 変換係数
	rd  = 1.d0 / d		!

	if(ind == 1) then

		if(i_trans /= 0) then
			alati = lc_x
			along = lc_y
			return
		end if

		rlat0 = rd * lc_lat0
		slat0 = dsin(rlat0)
		clat0 = dcos(rlat0)

		r = a * (1.d0 - e2)/dsqrt((1.d0 - e2*slat0**2)**3)
		an = a / dsqrt(1.d0 - e2 * slat0**2)
!		an = a / dsqrt(1.d0 - e12 * clat0**2)

		v2 = 1.d0 + e12 * clat0**2
		c1 = d/r
		c2 = d/an

		ph1 = lc_lat0 + c1 * lc_y
		rph1 = ph1 * rd
		tphi1 = dtan(rph1)
		cphi1 = dcos(rph1)

		alati = ph1 - (c2*lc_x)**2 * v2 * tphi1 / (2.d0*d)
		along = lc_lng0 + (c2*lc_x) / cphi1 - (c2*lc_x)**3 * (1.d0 + 2.d0 * tphi1**2) / (6.d0 * d**12 * cphi1)

		return

	else
		if(i_trans /= 0) then
			lc_x = alati
			lc_y = along
			return
		end if

		rlat = rd * alati
		slat = dsin(rlat)
		clat = dcos(rlat)

		v2 = 1.d0 + e12 * clat**2
		al = along - lc_lng0

		ph1 = alati + (v2 * al**2 * slat * clat) / (2.d0 * d)
		rph1 = ph1 * rd
		rph2 = (ph1 + lc_lat0) * 0.5d0 * rd
		sphi1 = dsin(rph1)
		sphi2 = dsin(rph2)

		r = a * (1.d0 - e2) / dsqrt((1.d0 - e2 * sphi2**2)**3)
		an = a / dsqrt(1.d0 - e2 * sphi1**2)
		c1 = d/r
		c2 = d/an

		lc_y = (ph1 - lc_lat0) / c1
		lc_x = (al * clat) / c2 + (al**3 * clat * dcos(2.d0*rlat)) / (6.d0 * c2 * d**2)

		return

	end if

end subroutine LL2XY

!==========
subroutine ROTATE(u,v,ut,vt,iab,ind, rot_phi,rot_dlt)

	implicit none
!	(rot_phi,rot_dlt) = (Aphi, Adlt) in CTP 断層の走行・傾斜
!--------------------------------------------------------
! (IAB,IND)
! (1, 1):  X-Y COODINATE rotation APHI deg counter-clockwisely.
!             Transform from LOCAL COOD. to FAULT COOD.
! (1,-1):  X-Y COODINATE rotation APHI deg clockwisely.
!             Transform from FAULT COOD. to LOCAL COOD.
! (2, 1):  Y-Z COODINATE rotation ADLT deg counter-clockwisely.
!             Transform from FAULT Cood. to ModelSurface COOD.
! (2,-1):  Y-Z COODINATE rotation ADLT deg clockwisely.
!             Transform from ModelSurface COOD. to FAULT COOD>
!--------------------------------------------------------
	real(8), intent(inout) :: u, v, ut, vt
	real(8), intent(in) :: rot_phi, rot_dlt
	integer, intent(in) :: iab, ind

	real(8), parameter :: pi = 3.14159265358979324d0

	real(8) :: p11, p12
	real(8) :: u11, u12, t11, t12

	t11 = dcos(rot_phi * pi/180.d0)
	t12 = dsin(rot_phi * pi/180.d0)
	u11 = dcos(rot_dlt * pi/180.d0)
	u12 = dsin(rot_dlt * pi/180.d0)

	p11 = 0.d0
	p12 = 0.d0

	if(iab == 1) then
		p11 = t11
		p12 = t12
	else if(iab == 2) then
		p11 = u11
		p12 = u12
	else
		stop " in TRANS, [iab] is bad value. "
	end if

	if(ind == 1) then
		ut =  p11 * u + p12 * v
		vt = -p12 * u + p11 * v
	else if(ind == -1) then
		ut =  p11 * u - p12 * v
		vt =  p12 * u + p11 * v
	end if

return
end subroutine ROTATE

end module mod_trans


c Determine the fastest traveltime between a source
c at depth=depth(km) and a receiver at distance=delta(km).

	subroutine ttime(delta, depth, nl, v, top, t, ain)

	implicit none

	include "hypoDD.inc"

c	Parameters:
	real	delta
	real	depth
	integer	nl
	real	v(MAXLAY)
	real	top(MAXLAY)
	real	t
	real	ain

c	Local variables:
	integer	jl
	integer	kk
	real	tdir
	real	thk(20)
	real	tkj
	real	tref
	real	u
	real	vsq(20)
	real	x
	real	xovmax

c	compile and link for S
c	f77 -c ttime.f
c	ld -r -dn ttime.o
c	mv a.out ttime.o

c	subroutine direct1 is used to compute the direct ray
c	traveltime and sine of takeoff angle.

c	subroutine refract is used to compute the fastest
c	refracted ray traveltime.  It calls subroutine tiddid.

c	subroutine vmodel extract needed information from the
c	layered velocity model.

c	input:
c	delta	epicentral distance in km
c	depth	focal depth of source in km
c	nl	number of layers in velocity model
c	v	velocity in each layer
c	top	depth to top of layer

c	output:
c	t	minimum traveltime
c	ain	angle of emergence at source

c	call vmodel to set-up model and locate source in it

	call vmodel(nl,v,top,depth,vsq,thk,jl,tkj)

c  output:
c      vsq(l) - v(l) ** 2
c      thk(l) - thickness of layer l
c          jl - event layer
c         tkj - depth of event in event layer

c	call refract to find fastest refracted arrival

	call refract(nl,v,vsq,thk,jl,tkj,delta,
     &			kk,tref,xovmax)

c  output:   kk - refracting layer for fastest refracted ray
c          tref - travel time of fastest refracted ray
c        xovmax - an upper bound on delta for which the direct ray
c                 can be the first arrival

c	if delta <= xovmax, them
c	call direct1 to find the direct ray traveltime
c	otherwise tref is the minimum traveltime

c	assume for now refracted path is faster

	t=tref

c	compute the takeoff angle
	if (kk.gt.0) then

	u=v(jl)/v(kk)
	ain=asin(u)*57.2958
	endif

	if (delta.le.xovmax) then

	call direct1(nl,v,vsq,thk,jl,tkj,delta,depth,tdir,u,x)

c  output:  tdir - direct ray travel time
c              u - sine of the takeoff angle
c              x - horizontal travel distance in the event layer
c

c	compare the traveltimes

	if (tref.gt.tdir) then

c	direct time is the minimum traveltime

	t=tdir
	ain=180-asin(u)*57.2958

	endif
	endif

	return
c *****	end of subroutine ttime *****
	end


program test_gaussians_atoms

! The paper [2] uses 6-31G* basis (we use 6-31G**):

! [2] Johnson, B. G., Gill, P. M. W., & Pople, J. A. (1993). The
! performance of a family of density functional methods. Journal of Chemical
! Physics, 98(7), 5612-5626.

use types, only: dp
use drivers, only: rhf_gauss
use mbpt, only: transform_int2, mbpt2, mbpt3
use gf, only: plot_poles
use utils, only: assert
implicit none
real(dp), allocatable :: C(:, :), lam(:), int2(:), moint2(:)
real(dp) :: E0, E2, E3, Etot, Enuc, Ekin
integer :: Nscf, Nelec
real(dp) :: alpha, tolE, tolP

tolE = 1e-10_dp
tolP = 1e-8_dp
alpha = 1._dp
Nscf = 40
! He
call rhf_gauss([2], reshape( &
    [0._dp, 0._dp, 0._dp], &
    [3, 1]), Nscf, alpha, tolE, tolP, C, lam, int2, E0, Enuc, Ekin, Etot)
allocate(moint2(size(int2)))
moint2 = transform_int2(int2, C)
print *, "Calculating MPBT 2"
Nelec = 2
E2 = mbpt2(moint2, lam, Nelec/2)
print *, "Calculating MPBT 3"
E3 = mbpt3(moint2, lam, Nelec/2)
call print_energies()
deallocate(moint2)
! MPQC:      -2.855 160
! Jaguar:    -2.855 160
! [2]:       -2.855 2
! GAMESS-UK: -2.855 160 4262
call assert(abs(Etot - (-2.8551604262_dp)) < 1e-10_dp)
! MPQC:      -0.025 477
! Jaguar:    -0.025 477
! [2]:       -0.011 2
! GAMESS-UK: -0.025 477 03
call assert(abs(E2 - (-0.02547703_dp)) < 1e-6_dp)
! GAMESS-UK: -0.005 442 24
call assert(abs(E3 - (-0.00544224_dp)) < 1e-6_dp)

! Be
call rhf_gauss([4], reshape( &
    [0._dp, 0._dp, 0._dp], &
    [3, 1]), Nscf, alpha, tolE, tolP, C, lam, int2, E0, Enuc, Ekin, Etot)
allocate(moint2(size(int2)))
moint2 = transform_int2(int2, C)
print *, "Calculating MPBT 2"
Nelec = 4
E2 = mbpt2(moint2, lam, Nelec/2)
print *, "Calculating MPBT 3"
E3 = mbpt3(moint2, lam, Nelec/2)
call print_energies()
! This is how to plot poles:
!call plot_poles(moint2, lam, Nelec/2)
deallocate(moint2)
! MPQC:      -14.272 316 ! Wrong
! [2]:       -14.566 9
! GAMESS-UK: -14.569 853 664 5
call assert(abs(Etot - (-14.56694436_dp)) < 1e-8_dp)
! MPQC:      -0.042 703 ! Wrong
! [2]:       -0.029 5
! GAMESS-UK: -0.027 205 00
call assert(abs(E2 - (-0.02950068_dp)) < 1e-6_dp)
! GAMESS-UK: -0.009 907 62
call assert(abs(E3 - (-0.01056728_dp)) < 1e-6_dp)

! Ne
call rhf_gauss([10], reshape( &
    [0._dp, 0._dp, 0._dp], &
    [3, 1]), Nscf, alpha, tolE, tolP, C, lam, int2, E0, Enuc, Ekin, Etot)
allocate(moint2(size(int2)))
moint2 = transform_int2(int2, C)
print *, "Calculating MPBT 2"
Nelec = 10
E2 = mbpt2(moint2, lam, Nelec/2)
print *, "Calculating MPBT 3"
E3 = mbpt3(moint2, lam, Nelec/2)
call print_energies()
deallocate(moint2)
! PyQuante vs libint: 9.7e-8
! MPQC:      -128.474 407
! GAMESS-UK: -128.474 406 519 9
! [2]:       -128.474 4
call assert(abs(Etot - (-128.4744065196_dp)) < 1e-10_dp)
! MPQC:        -0.150 316  ! Wrong
! [2]:         -0.151 8
! GAMESS-UK    -0.15176955
call assert(abs(E2 - (-0.15176955_dp)) < 1e-6_dp)
! GAMESS-UK     0.00015112
call assert(abs(E3 - (0.00015112_dp)) < 1e-6_dp)

! Mg
call rhf_gauss([12], reshape( &
    [0._dp, 0._dp, 0._dp], &
    [3, 1]), Nscf, alpha, tolE, tolP, C, lam, int2, E0, Enuc, Ekin, Etot)
allocate(moint2(size(int2)))
moint2 = transform_int2(int2, C)
print *, "Calculating MPBT 2"
Nelec = 12
E2 = mbpt2(moint2, lam, Nelec/2)
print *, "Calculating MPBT 3"
E3 = mbpt3(moint2, lam, Nelec/2)
call print_energies()
deallocate(moint2)
! PyQuante vs libint: 1.5e-7
! MPQC       -199.595 610 920 833
! GAMESS-UK  -199.595 610 917 0
call assert(abs(Etot - (-199.59561092_dp)) < 1e-8_dp)
! MPQC       -0.021 986 440 863
! GAMESS-UK  -0.028 462 86
call assert(abs(E2 - (-0.02846287_dp)) < 1e-6_dp)
! GAMESS-UK  -0.007 145 35
call assert(abs(E3 - (-0.00714535_dp)) < 1e-6_dp)

! Ar
call rhf_gauss([18], reshape( &
    [0._dp, 0._dp, 0._dp], &
    [3, 1]), Nscf, alpha, tolE, tolP, C, lam, int2, E0, Enuc, Ekin, Etot)
allocate(moint2(size(int2)))
moint2 = transform_int2(int2, C)
print *, "Calculating MPBT 2"
Nelec = 12
E2 = mbpt2(moint2, lam, Nelec/2)
print *, "Calculating MPBT 3"
E3 = mbpt3(moint2, lam, Nelec/2)
call print_energies()
deallocate(moint2)
! PyQuante vs libint: 4.0e-7
! MPQC:      -526.773 744 920 946
! GAMESS-UK: -526.773 744 921 0
call assert(abs(Etot - (-526.77374492_dp)) < 1e-8_dp)
! MPQC:        -0.137308007079
! GAMESS-UK:   -0.14624537
call assert(abs(E2 - (-0.06205272_dp)) < 1e-6_dp)
! GAMESS-UK:   -0.01112785
call assert(abs(E3 - (-0.02128214_dp)) < 1e-6_dp)

contains

subroutine print_energies(skip3)
logical, optional, intent(in) :: skip3
print *, "HF results:"
print "(a,es10.2)", "        EKIN+EHF (a.u.):", Ekin + Etot
print "(a,f18.8)", "  KINETIC ENERGY (a.u.):", Ekin
print "(a,f18.8)", "HF ATOMIC ENERGY (a.u.):", Etot
print *
print *, "MBPT results:"
print "(' E0+E1 (HF)    = ',f15.8)", Etot
print "(' E2    (MBPT2) = ',f15.8)", E2
if (.not. present(skip3)) print "(' E3    (MBPT3) = ',f15.8)", E3
print "(' E0+E1+E2      = ',f15.8)", Etot + E2
if (.not. present(skip3)) print "(' E0+E1+E2+E3   = ',f15.8)", Etot + E2 + E3
end subroutine

end program