!=========================================================
subroutine rp1(maxmx, meqn, mwaves, maux, mbc, mx, ql, qr, auxl, auxr, wave, s, amdq, apdq)
!=========================================================
!
! Roe-solver for the 1D ideal MHD equations
!
! waves:     7
! equations: 8
!
! Conserved quantities:
!       1 density
!       2 momentum, x
!       3 momentum, y
!       4 momentum, z
!       5 energy
!       6 magnetic field, x
!       7 magnetic field, y
!       8 magnetic field, z
!
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q
!            (where the flux difference is f(qr(i-1)) - f(ql(i)))
!
! With the Roe solver we have
!   amdq  =  A^- \Delta q    and    apdq  =  A^+ \Delta q
! where A is the Roe matrix.
! An entropy fix can also be incorporated into the flux differences.
!
! Note that the i'th Riemann problem has left state qr(:, i-1)
!                                    and right state ql(:, i)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit none

    integer, intent(in) :: maxmx, meqn, mwaves, maux, mbc, mx
    double precision, dimension(meqn, 1-mbc:maxmx+mbc),         intent(in)  :: ql, qr
    double precision, dimension(maux, 1-mbc:maxmx+mbc),         intent(in)  :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxmx+mbc), intent(out) :: wave
    double precision, dimension(meqn, 1-mbc:maxmx+mbc),         intent(out) :: amdq, apdq
    double precision, dimension(mwaves, 1-mbc:maxmx+mbc),       intent(out) :: s

    ! meqn == 8, mwaves == 7
    double precision, dimension(meqn)        :: fl, fr, df
    double precision, dimension(4)           :: eigl, eigr
    double precision, dimension(mwaves)      :: stmp
    double precision, dimension(meqn,mwaves) :: rr
    double precision, dimension(mwaves,meqn) :: rl
    double precision, dimension(mwaves)      :: alpha, beta

    integer ixy, i, mu1, mu2, mb1, mb2, m1, m2, mm, mflag
    double precision gamma, gamma1
    double precision rho, rhol, rhor, u1, u1l, u1r, u2, u2l, u2r, u3, u3l, u3r, El, Er, p, pl, pr
    double precision B1, B1l, B1r, B2, B2l, B2r, B3, B3l, B3r
    double precision sl, sr, qs

    logical efix

    common /cparam/ gamma, gamma1

    ! use entropy fix for transonic rarefactions
    data efix /.true./

    ixy = 1
    if (ixy == 1) then
        mu1 = 2
        mu2 = 3
        mb1 = 6
        mb2 = 7
    elseif (ixy == 2) then
        mu1 = 3
        mu2 = 2
        mb1 = 7
        mb2 = 6
    endif

    do i = 2-mbc, mx+mbc
        ! Left and right states
        rhol = qr(1, i-1)
        rhor = ql(1, i  )

        ! There is an issue with uninitialized states at the far left and right ghost cells for sharpclaw.
        ! David Ketcheson will open an issue in pyclaw
        if (i > 3-mbc .and. i < mx+mbc-1 .and. (rhol <= 1.d-15 .or. isnan(rhol) .or. rhor <= 1.d-15 .or. isnan(rhor))) then
            print*, ' '
            print*, ' ERROR in RPN:  rhol = ', rhol
            print*, ' ERROR in RPN:  rhor = ', rhor
            print*, '                Cell = ', i
            print*, '             maxmx   = ', maxmx
            print*, '             meqn    = ', meqn
            print*, '             mwaves  = ', mwaves
            print*, '             maux    = ', maux
            print*, '             mbc     = ', mbc
            print*, '             mx      = ', mx
            print*, ' '
            stop
        endif

        u1l = qr(mu1, i-1) / rhol
        u2l = qr(mu2, i-1) / rhol
        u3l = qr(4,   i-1) / rhol
        El  = qr(5,   i-1)
        B1l = qr(mb1, i-1)
        B2l = qr(mb2, i-1)
        B3l = qr(8,   i-1)
        pl  = gamma1 * (El - 0.5d0 * rhol * (u1l**2 + u2l**2 + u3l**2) - 0.5d0 * (B1l**2 + B2l**2 + B3l**2))

        u1r = ql(mu1, i  ) / rhor
        u2r = ql(mu2, i  ) / rhor
        u3r = ql(4,   i  ) / rhor
        Er  = ql(5,   i  )
        B1r = ql(mb1, i  )
        B2r = ql(mb2, i  )
        B3r = ql(8,   i  )
        pr  = gamma1 * (Er - 0.5d0 * rhor * (u1r**2 + u2r**2 + u3r**2) - 0.5d0 * (B1r**2 + B2r**2 + B3r**2))

        if (i > 3-mbc .and. i < mx+mbc-1 .and. (pl <= 1.d-15 .or. isnan(pl) .or. pr <= 1.d-15 .or. isnan(pr))) then
            print*, ' '
            print*, ' ERROR in RPN:  pl = ', pl
            print*, ' ERROR in RPN:  pr = ', pr
            print*, '                Cell = ', i
            print*, '             maxmx   = ', maxmx
            print*, '             meqn    = ', meqn
            print*, '             mwaves  = ', mwaves
            print*, '             maux    = ', maux
            print*, '             mbc     = ', mbc
            print*, '             mx      = ', mx
            print*, ' '
            stop
        endif

        ! Average states
        rho = 0.5d0 * (rhol + rhor)
        u1  = 0.5d0 * (u1l + u1r)
        u2  = 0.5d0 * (u2l + u2r)
        u3  = 0.5d0 * (u3l + u3r)
        p   = 0.5d0 * (pl + pr)
        B1  = 0.5d0 * (B1l + B1r)
        B2  = 0.5d0 * (B2l + B2r)
        B3  = 0.5d0 * (B3l + B3r)

        ! Delta f
        call set_flux_fun(mu1, mu2, mb1, mb2, rhol, u1l, u2l, u3l, pl, B1l, B2l, B3l, El, fl)
        call set_flux_fun(mu1, mu2, mb1, mb2, rhor, u1r, u2r, u3r, pr, B1r, B2r, B3r, Er, fr)
        do m1 = 1, meqn
            df(m1) = fr(m1) - fl(m1)
        enddo

        ! Wave Speeds
        do mm = 1, mwaves
            stmp(mm) = 0.d0
        enddo
        call set_wave_spd(rhol, u1l, u2l, u3l, pl, B1l, B2l, B3l, gamma, stmp)
        eigl(1) = stmp(1)
        eigl(2) = stmp(3)
        eigl(3) = stmp(5)
        eigl(4) = stmp(7)
        call set_wave_spd(rhor, u1r, u2r, u3r, pr, B1r, B2r, B3r, gamma, stmp)
        eigr(1) = stmp(1)
        eigr(2) = stmp(3)
        eigr(3) = stmp(5)
        eigr(4) = stmp(7)
        call set_wave_spd(rho, u1, u2, u3, p, B1, B2, B3, gamma, stmp)
        do m1 = 1, mwaves
          s(m1, i) = stmp(m1)
        enddo

        ! Right Eigenvectors (row,column)
        call set_rght_eig(mu1, mu2, mb1, mb2, rho, u1, u2, u3, p, B1, B2, B3, gamma, rr)

        ! Left Eigenvectors (row,column)
        call set_left_eig(mu1, mu2, mb1, mb2, rho, u1, u2, u3, p, B1, B2, B3, gamma, rl)

        ! Betas and Alphas
        do m1 = 1, mwaves
            beta(m1) = 0.d0
            do m2 = 1, meqn
                beta(m1) = beta(m1) + rl(m1, m2) * df(m2)
            enddo

            if (dabs(s(m1, i)) > 1.d-15) then
                alpha(m1) = beta(m1) / s(m1, i)
            else
                s(m1, i)  = 0.d0
                alpha(m1) = 0.d0
            endif
        enddo

        ! Waves
        do m1 = 1, mwaves
            do m2 = 1, meqn
                wave(m2, m1, i) = alpha(m1) * rr(m2, m1)
            enddo
        enddo

        ! compute left-going and right-going flux differences:
        !------------------------------------------------------
        !
        ! amdq = SUM s*wave   over left-going waves
        ! apdq = SUM s*wave   over right-going waves

        mflag = 0
        if (efix) then
            ! check if entropy fix is needed
            do mm = 1, 4
                if (eigl(mm) * eigr(mm) < 0.d0) then
                    mflag = 1
                endif
            enddo
        endif

        ! Solution update
        if (mflag == 0) then ! # WAVE PROPAGATION METHOD

            do m1 = 1, meqn
                amdq(m1, i) = 0.d0
                apdq(m1, i) = 0.d0

                do m2 = 1, mwaves
                    if (s(m2, i) < -1.d-15) then
                        amdq(m1, i) = amdq(m1, i) + s(m2, i) * wave(m1, m2, i)
                    elseif (s(m2, i) > 1.d-15) then
                        apdq(m1, i) = apdq(m1, i) + s(m2, i) * wave(m1, m2, i)
                    else
                        if (dabs(beta(m2)) > 1.d-15) then
                            print*, ' '
                            print*, ' In RPN: Conservation fix '
                            print*, ' '
                            print*, ' beta(m2) = ', beta(m2)
                            read*
                        endif
                        amdq(m1, i) = amdq(m1, i) + 0.5d0*beta(m2)*rr(m1,m2)
                        apdq(m1, i) = apdq(m1, i) + 0.5d0*beta(m2)*rr(m1,m2)
                    endif
                enddo
            enddo

        else !# HLL ENTROPY FIX

            sl = eigl(1)
            sr = eigr(4)

            do m1 = 1, meqn
                if (dabs(sl-sr) < 1.d-15) then
                    amdq(m1, i) = 0.d0
                    apdq(m1, i) = 0.d0
                else
                    qs = (df(m1) + sl * qr(m1, i-1) - sr * ql(m1, i)) / (sl - sr)

                    amdq(m1, i) = sl * (qs - qr(m1, i-1))
                    apdq(m1, i) = sr * (ql(m1, i) - qs)
                endif

                do m2 = 1, mwaves
                    wave(m1, m2, i) = 0.d0
                enddo
            enddo

        endif

    enddo

    return
end

!=========================================================
subroutine set_flux_fun(mu1, mu2, mb1, mb2, rho, u1, u2, u3, p, B1, B2, B3, E, f)
!=========================================================

    implicit double precision (a-h,o-z)
    double precision, dimension(8), intent(out) :: f

    Bm = 0.5d0 * (B1**2 + B2**2 + B3**2)
    Bu = u1 * B1 + u2 * B2 + u3 * B3

    f(1)   = rho * u1
    f(mu1) = rho * u1**2 + p + Bm - B1**2
    f(mu2) = rho * u1*u2 - B1*B2
    f(4)   = rho * u1*u3 - B1*B3
    f(5)   = u1 * (E + p + Bm) - B1 * Bu
    f(mb1) = 0.d0
    f(mb2) = u1*B2 - u2*B1
    f(8)   = u1*B3 - u3*B1

    return
end

!=========================================================
subroutine set_left_eig(mu1, mu2, mb1, mb2, rho, u1, u2, u3, p, B1, B2, B3, gamma, rl)
!=========================================================

    implicit none
    integer, intent(in) :: mu1, mu2, mb1, mb2
    double precision, intent(in) :: rho, u1, u2, u3, p, B1, B2, B3, gamma
    double precision, dimension(7,8), intent(out) :: rl
    double precision a2, a, d, ca, cf, cs, beta1, beta2, beta3, alphaf, alphas, g1, g2, um2, th1, th2

    a2 = gamma * p / rho
    a = dsqrt(a2)
    d = a2 + (B1**2 + B2**2 + B3**2) / rho

    ca = dsqrt(B1**2 / rho)
    cf = dsqrt(0.5d0 * ( d + dsqrt(d**2 - 4.d0 * a2 * B1 * B1 / rho)))
    cs = dsqrt(0.5d0 * ( d - dsqrt(d**2 - 4.d0 * a2 * B1 * B1 / rho)))

    beta1 = dsign(1.d0, B1)
    if ( (dabs(B2) + dabs(B3)) <= 1.d-15 ) then
        beta2 = 1.d0 / dsqrt(2.d0)
        beta3 = 1.d0 / dsqrt(2.d0)
    else
        beta2 = B2 / dsqrt(B2*B2 + B3*B3)
        beta3 = B3 / dsqrt(B2*B2 + B3*B3)
    endif

    if ( (dabs(B2) + dabs(B3)) <= 1.d-15 .and. dabs(a2 - B1*B1/rho) <= 1.d-15 ) then
        alphaf = 1.d0
        alphas = 1.d0
    else
        alphaf = dsqrt(dabs(cf * cf - ca*ca)) / dsqrt(dabs(cf * cf - cs * cs))
        alphas = dsqrt(dabs(cf * cf - a2   )) / dsqrt(dabs(cf * cf - cs * cs))
    endif

    g1 = gamma - 1.d0
    g2 = gamma - 2.d0

    um2 = u1**2 + u2**2 + u3**2
    th1 = alphaf*alphaf*a2*(cf*cf - (g2/g1)*a2) + alphas*alphas*cf*cf*(cs*cs - (g2/g1)*a2)
    th1 = 1.d0 / th1
    th2 = alphaf*alphaf*cf*a*beta1 + alphas*alphas*cs*ca*beta1
    th2 = 1.d0 / th2

    ! 1 - left eigenvector
    rl(1,1)   = th1*(alphaf/4.d0)*a2*um2 + 0.5d0*th2*(alphaf*a*u1*beta1 - alphas*cs*(beta2*u2 + beta3*u3))
    rl(1,mu1) = -0.5d0*th1*alphaf*a2*u1 - 0.5d0*th2*alphaf*a*beta1
    rl(1,mu2) = -0.5d0*th1*alphaf*a2*u2 + 0.5d0*th2*alphas*cs*beta2
    rl(1,4)   = -0.5d0*th1*alphaf*a2*u3 + 0.5d0*th2*alphas*cs*beta3
    rl(1,5)   = 0.5d0*th1*alphaf*a2
    rl(1,mb1) = 0.d0
    rl(1,mb2) = 0.5d0*th1*alphas*beta2*cf*(cs*cs - (g2/g1)*a2)*dsqrt(rho)
    rl(1,8)   = 0.5d0*th1*alphas*beta3*cf*(cs*cs - (g2/g1)*a2)*dsqrt(rho)

    ! 2 - left eigenvector
    rl(2,1)   = -0.5d0*(beta3*u2-beta2*u3)*beta1
    rl(2,mu1) = 0.d0
    rl(2,mu2) = 0.5d0*beta3*beta1
    rl(2,4)   = -0.5d0*beta2*beta1
    rl(2,5)   = 0.d0
    rl(2,mb1) = 0.d0
    rl(2,mb2) = 0.5d0*beta3*dsqrt(rho)
    rl(2,8)   = -0.5d0*beta2*dsqrt(rho)

    ! 3 - left eigenvector
    rl(3,1)   = th1*(alphas/4.d0)*cf*cf*um2 + 0.5d0*th2*(alphas*ca*u1*beta1 + alphaf*cf*(beta2*u2 + beta3*u3))
    rl(3,mu1) = -0.5d0*th1*alphas*cf*cf*u1 - 0.5d0*th2*alphas*ca*beta1
    rl(3,mu2) = -0.5d0*th1*alphas*cf*cf*u2 - 0.5d0*th2*alphaf*cf*beta2
    rl(3,4)   = -0.5d0*th1*alphas*cf*cf*u3 - 0.5d0*th2*alphaf*cf*beta3
    rl(3,5)   = 0.5d0*th1*alphas*cf*cf
    rl(3,mb1) = 0.d0
    rl(3,mb2) = -0.5d0*th1*alphaf*beta2*cf*(cf*cf - (g2/g1)*a2)*dsqrt(rho)
    rl(3,8)   = -0.5d0*th1*alphaf*beta3*cf*(cf*cf - (g2/g1)*a2)*dsqrt(rho)

    ! 4 - left eigenvector
    rl(4,1)   = 1.d0 - 0.5d0*th1*(alphaf*alphaf*a2 + alphas*alphas*cf*cf)*um2
    rl(4,mu1) = th1*(alphaf*alphaf*a2 + alphas*alphas*cf*cf)*u1
    rl(4,mu2) = th1*(alphaf*alphaf*a2 + alphas*alphas*cf*cf)*u2
    rl(4,4)   = th1*(alphaf*alphaf*a2 + alphas*alphas*cf*cf)*u3
    rl(4,5)   = -th1*(alphaf*alphaf*a2 + alphas*alphas*cf*cf)
    rl(4,mb1) = 0.d0
    rl(4,mb2) = th1*alphaf*alphas*beta2*cf*(cf*cf-cs*cs)*dsqrt(rho)
    rl(4,8)   = th1*alphaf*alphas*beta3*cf*(cf*cf-cs*cs)*dsqrt(rho)

    ! 5 - left eigenvector
    rl(5,1)   = th1*(alphas/4.d0)*cf*cf*um2 - 0.5d0*th2*(alphas*ca*u1*beta1 + alphaf*cf*(beta2*u2 + beta3*u3))
    rl(5,mu1) = -0.5d0*th1*alphas*cf*cf*u1 + 0.5d0*th2*alphas*ca*beta1
    rl(5,mu2) = -0.5d0*th1*alphas*cf*cf*u2 + 0.5d0*th2*alphaf*cf*beta2
    rl(5,4)   = -0.5d0*th1*alphas*cf*cf*u3 + 0.5d0*th2*alphaf*cf*beta3
    rl(5,5)   = 0.5d0*th1*alphas*cf*cf
    rl(5,mb1) = 0.d0
    rl(5,mb2) = -0.5d0*th1*alphaf*beta2*cf*(cf*cf - (g2/g1)*a2)*dsqrt(rho)
    rl(5,8)   = -0.5d0*th1*alphaf*beta3*cf*(cf*cf - (g2/g1)*a2)*dsqrt(rho)

    ! 6 - left eigenvector
    rl(6,1)   = 0.5d0*(beta3*u2-beta2*u3)*beta1
    rl(6,mu1) = 0.d0
    rl(6,mu2) = -0.5d0*beta3*beta1
    rl(6,4)   = 0.5d0*beta2*beta1
    rl(6,5)   = 0.d0
    rl(6,mb1) = 0.d0
    rl(6,mb2) = 0.5d0*beta3*dsqrt(rho)
    rl(6,8)   = -0.5d0*beta2*dsqrt(rho)

    ! 7 - left eigenvector
    rl(7,1)   = th1*(alphaf/4.d0)*a2*um2 - 0.5d0*th2*(alphaf*a*u1*beta1 - alphas*cs*(beta2*u2 + beta3*u3))
    rl(7,mu1) = -0.5d0*th1*alphaf*a2*u1 + 0.5d0*th2*alphaf*a*beta1
    rl(7,mu2) = -0.5d0*th1*alphaf*a2*u2 - 0.5d0*th2*alphas*cs*beta2
    rl(7,4)   = -0.5d0*th1*alphaf*a2*u3 - 0.5d0*th2*alphas*cs*beta3
    rl(7,5)   = 0.5d0*th1*alphaf*a2
    rl(7,mb1) = 0.d0
    rl(7,mb2) = 0.5d0*th1*alphas*beta2*cf*(cs*cs - (g2/g1)*a2)*dsqrt(rho)
    rl(7,8)   = 0.5d0*th1*alphas*beta3*cf*(cs*cs - (g2/g1)*a2)*dsqrt(rho)

    return
end

!=========================================================
subroutine set_rght_eig(mu1, mu2, mb1, mb2, rho, u1, u2, u3, p, B1, B2, B3, gamma, rr)
!=========================================================

    implicit none
    integer, intent(in) :: mu1, mu2, mb1, mb2
    double precision, intent(in) :: rho, u1, u2, u3, p, B1, B2, B3, gamma
    double precision, dimension(8,7), intent(out) :: rr
    double precision a2, a, d, ca, cf, cs, beta1, beta2, beta3, alphaf, alphas, g1, g2, hmf, hpf, hms, hps

    a2 = gamma * p / rho
    a = dsqrt(a2)
    d = a2 + (B1**2 + B2**2 + B3**2) / rho

    ca = dsqrt(B1**2 / rho)
    cf = dsqrt(0.5d0 * ( d + dsqrt(d**2 - 4.d0*a2*B1*B1/rho)))
    cs = dsqrt(0.5d0 * ( d - dsqrt(d**2 - 4.d0*a2*B1*B1/rho)))

    beta1 = dsign(1.d0, B1)
    if ( (dabs(B2) + dabs(B3)) <= 1.d-15 ) then
        beta2 = 1.d0 / dsqrt(2.d0)
        beta3 = 1.d0 / dsqrt(2.d0)
    else
        beta2 = B2 / dsqrt(B2*B2 + B3*B3)
        beta3 = B3 / dsqrt(B2*B2 + B3*B3)
    endif

    if ( (dabs(B2) + dabs(B3)) <= 1.d-15 .and. dabs(a2 - B1*B1/rho) < 1.d-15 ) then
        alphaf = 1.d0
        alphas = 1.d0
    else
        alphaf = dsqrt(dabs(cf*cf - ca*ca)) / dsqrt(dabs(cf*cf-cs*cs))
        alphas = dsqrt(dabs(cf*cf - a2)) / dsqrt(dabs(cf*cf-cs*cs))
    endif

    g1 = gamma - 1.d0
    g2 = gamma - 2.d0
    hmf = (alphaf*cf*cf/g1) - alphaf*cf*u1 + alphas*ca*beta1*(beta2*u2 + beta3*u3) + (g2/g1)*alphaf*(cf*cf-a2)
    hpf = (alphaf*cf*cf/g1) + alphaf*cf*u1 - alphas*ca*beta1*(beta2*u2 + beta3*u3) + (g2/g1)*alphaf*(cf*cf-a2)
    hms = (alphas*cs*cs/g1) - alphas*cs*u1 - alphaf*a*beta1*(beta2*u2 + beta3*u3) + (g2/g1)*alphas*(cs*cs-a2)
    hps = (alphas*cs*cs/g1) + alphas*cs*u1 + alphaf*a*beta1*(beta2*u2 + beta3*u3) + (g2/g1)*alphas*(cs*cs-a2)

    ! 1 - right eigenvector
    rr(1,1)   = alphaf
    rr(mu1,1) = alphaf*(u1-cf)
    rr(mu2,1) = alphaf*u2 + alphas*beta2*ca*beta1
    rr(4,1)   = alphaf*u3 + alphas*beta3*ca*beta1
    rr(5,1)   = 0.5d0*alphaf*(u1**2 + u2**2 + u3**2) + hmf
    rr(mb1,1) = 0.d0
    rr(mb2,1) = alphas*beta2*cf/dsqrt(rho)
    rr(8,1)   = alphas*beta3*cf/dsqrt(rho)

    ! 2 - right eigenvector
    rr(1,2)   = 0.d0
    rr(mu1,2) = 0.d0
    rr(mu2,2) = beta3*beta1
    rr(4,2)   = -beta2*beta1
    rr(5,2)   = (beta3*u2 - beta2*u3)*beta1
    rr(mb1,2) = 0.d0
    rr(mb2,2) = beta3/dsqrt(rho)
    rr(8,2)   = -beta2/dsqrt(rho)

    ! 3 - right eigenvector
    rr(1,3)   = alphas
    rr(mu1,3) = alphas*(u1-cs)
    rr(mu2,3) = alphas*u2 - alphaf*beta2*a*beta1
    rr(4,3)   = alphas*u3 - alphaf*beta3*a*beta1
    rr(5,3)   = 0.5d0*alphas*(u1**2 + u2**2 + u3**2) + hms
    rr(mb1,3) = 0.d0
    rr(mb2,3) = -alphaf*beta2*a2/(cf*dsqrt(rho))
    rr(8,3)   = -alphaf*beta3*a2/(cf*dsqrt(rho))

    ! 4 - right eigenvector
    rr(1,4)   = 1.d0
    rr(mu1,4) = u1
    rr(mu2,4) = u2
    rr(4,4)   = u3
    rr(5,4)   = 0.5d0*(u1**2 + u2**2 + u3**2)
    rr(mb1,4) = 0.d0
    rr(mb2,4) = 0.d0
    rr(8,4)   = 0.d0

    ! 5 - right eigenvector
    rr(1,5)   = alphas
    rr(mu1,5) = alphas*(u1+cs)
    rr(mu2,5) = alphas*u2 + alphaf*beta2*a*beta1
    rr(4,5)   = alphas*u3 + alphaf*beta3*a*beta1
    rr(5,5)   = 0.5d0*alphas*(u1**2 + u2**2 + u3**2) + hps
    rr(mb1,5) = 0.d0
    rr(mb2,5) = -alphaf*beta2*a2/(cf*dsqrt(rho))
    rr(8,5)   = -alphaf*beta3*a2/(cf*dsqrt(rho))

    ! 6 - right eigenvector
    rr(1,6)   = 0.d0
    rr(mu1,6) = 0.d0
    rr(mu2,6) = -beta3*beta1
    rr(4,6)   = beta2*beta1
    rr(5,6)   = -(beta3*u2 - beta2*u3)*beta1
    rr(mb1,6) = 0.d0
    rr(mb2,6) = beta3/dsqrt(rho)
    rr(8,6)   = -beta2/dsqrt(rho)

    ! 7 - right eigenvector
    rr(1,7)   = alphaf
    rr(mu1,7) = alphaf*(u1+cf)
    rr(mu2,7) = alphaf*u2 - alphas*beta2*ca*beta1
    rr(4,7)   = alphaf*u3 - alphas*beta3*ca*beta1
    rr(5,7)   = 0.5d0*alphaf*(u1**2 + u2**2 + u3**2) + hpf
    rr(mb1,7) = 0.d0
    rr(mb2,7) = alphas*beta2*cf/dsqrt(rho)
    rr(8,7)   = alphas*beta3*cf/dsqrt(rho)

    return
end

!=========================================================
subroutine set_wave_spd(rho, u1, u2, u3, p, B1, B2, B3, gamma, s)
!=========================================================

    implicit none
    double precision, intent(in) :: rho, u1, u2, u3, p, B1, B2, B3, gamma
    double precision, dimension(7), intent(out) :: s
    double precision  a2, d, ca, cf, cs

    a2 = gamma * p / rho
    d = a2 + (B1**2 + B2**2 + B3**2) / rho

    ca = dsqrt(B1**2/rho)
    cf = dsqrt(0.5d0 * ( d + dsqrt(d**2 - 4.d0*a2*B1*B1/rho)))
    cs = dsqrt(0.5d0 * ( d - dsqrt(d**2 - 4.d0*a2*B1*B1/rho)))

    s(1) = u1 - cf
    s(2) = u1 - ca
    s(3) = u1 - cs
    s(4) = u1
    s(5) = u1 + cs
    s(6) = u1 + ca
    s(7) = u1 + cf

    return
end


program main
use,intrinsic :: ISO_FORTRAN_ENV, only : REAL64,STDOUT=>OUTPUT_UNIT
use mod_carton
implicit none
integer,parameter          :: NITER      = 1000000
integer,parameter          :: SNAP       = 10000
type(carton)               :: car1,car2
integer                    :: iter
!
  call car1%load(5)
! call car1%init()
! call car1%dump(10)
  call car2%clone(car1)
!
  do iter=0,NITER
!
    call car1%calc_force()
!
    if(MODULO(iter,SNAP)==0)then
      call car1%dump(iter/SNAP+11)
      print'(i8,G24.9,*(f16.9))',iter/SNAP,car1%cost(),car1%surface(),car1%volume()
      FLUSH(STDOUT)
    endif
!
    call linear_search( )
!
  enddo
!
  open(10,FILE='carton.csv')
  call car1%export(10)
  close(10)
!
contains
!
  subroutine linear_search()
  real(REAL64),parameter  :: thre    = 1D-4
  integer,parameter       :: maxiter = 100
  real(REAL64)            :: s(0:2),f(2)
  real(REAL64)            :: sr,fr ! reflect
  real(REAL64)            :: se,fe ! expand
  real(REAL64)            :: si,fi ! inner contract
  real(REAL64)            :: so,fo ! outer contract
  real(REAL64)            :: conv
  integer                 :: best,worst
  integer                 :: i
!
! nelder_mead parameters
!
!    alpha = 1d0
!    beta  = 2d0
!    gam   = 5d-1
!
    s(1)   = 0D0  ; f(1) = cost()
    s(2)   = 1D0  ; f(2) = cost(s(2))
    s(0)   = s(MINLOC(f,1))
!
    conv   = 0D0
!
    do i=1,maxiter
!
      best  = MINLOC(f,1) ; worst = MAXLOC(f,1)
!
! X_c = X_best in 1D simplex
! sr is refrected points : S = s(best) + alpha * (s(best) - s(worst))
!
      sr     = s(best) + s(best) - s(worst)
      fr     = cost( sr )
!
      if(f(best) <= fr .and. fr < f(worst))then
        s(worst) = sr ; f(worst) = fr
      elseif(fr < f(best))then
!! se is expanded point : S = s(best) + beta * (sr - s(best))
        se     = sr + sr - s(best)
        fe     = cost( se )
        if(fe < fr)then ; s(worst) = se ; f(worst) = fe
        else            ; s(worst) = sr ; f(worst) = fr
        endif
      else
!! se is inner or outer contraction point : S = s(best) + gam * (sr - s(best))
        si   = 0.5D0 * (s(best) + sr)
        fi   = cost( si )
!!  as S = s(best) - gam * (sr - s(best))
        so   = 1.5D0 * s(best) - 0.5D0 * sr
        fo   = cost( so )
        if(fi<fo)then ; s(worst) = si ; f(worst) = fi
        else          ; s(worst) = so ; f(worst) = fo
        endif
      endif
!
      s(0) = s(1)*s(1) + s(2)*s(2)
      conv = abs(conv - s(0))/s(0)
!
      if(conv < thre) EXIT
!
      conv = s(0)
!
    enddo
!
    call car1%move( s(best) )
!
  end subroutine linear_search
!
  function cost(s) result(res)
  real(REAL64),intent(in),optional :: s
  real(REAL64)                     :: res
!
    res = 0D0
!
    car2 = car1
    if(PRESENT(s)) call car2%move(s)
!
    call car2%calc_force()
    res = car2%cost()
!
  end function cost
!
end program main


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE L2SMO (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT, EPS,
     &   RO)
C***********************************************************************

C  SUBROUTINE L2SMO = LAPLACIAN SQUARED METHOD OF MESH SMOOTHING

C***********************************************************************

C  NOTE:
C     THIS METHOD IS LIKE LAPLACIAN SMOOTHING EXCEPT EACH VECTOR
C     POINTING TO A NEIGHBOR NODE HAS A LENGTH OF
C      (DISTANCE TO THAT NODE)**2.

C***********************************************************************

C  VARIABLES USED:
C     NIT = MAX NUMBER OF ITERATIONS TO DO
C     EPS = NODE MOVEMENT TOLERANCE FOR CONVERGENCE
C     RO  = UNDER OR OVER-RELAXATION FACTOR.

C***********************************************************************

      DIMENSION LINES (20)
      DIMENSION NXL (2, 3*MXND), LXN (4, MXND), XN (MXND), YN (MXND)

      LOGICAL BIG, ERR

      EPS2 = (EPS * RO) ** 2

C  ITERATION LOOP

      DO 120 IT = 1, NIT
         BIG = .FALSE.

C  NODE LOOP

         DO 110 NODE = NNNOLD + 1, NNN
            IF ((LXN (1, NODE).GT.0) .AND. (LXN (2, NODE).GT.0))THEN
               FX = 0.
               FY = 0.
               SL = 0.

C  LOOP THROUGH ALL LINES CONNECTED TO NODE

               CALL GETLXN (MXND, LXN, NODE, LINES, KOUNT, ERR)
               IF (ERR) RETURN
               DO 100 IL = 1, KOUNT
                  L = LINES (IL)
                  NEND = NXL (1, L) + NXL (2, L) - NODE
                  DX = XN (NEND) - XN (NODE)
                  DY = YN (NEND) - YN (NODE)
                  AL2 = DX * DX + DY * DY
                  AL = SQRT (AL2)
                  FX = FX + DX * AL
                  FY = FY + DY * AL
                  SL = SL + AL
  100          CONTINUE

C  MOVE THE NODE

               DELX = RO * FX/SL
               DELY = RO * FY/SL
               XN (NODE) = XN (NODE) + DELX
               YN (NODE) = YN (NODE) + DELY
               IF (DELX ** 2 + DELY ** 2 .GT. EPS2) BIG = .TRUE.
            ENDIF
  110    CONTINUE
         IF (.NOT.BIG)RETURN
  120 CONTINUE
      RETURN
      END


program Lanternfish
    implicit none
    integer, parameter :: MAX = 8
    integer, parameter :: INPUT_SIZE = 300
    integer(kind = 8), dimension(0:MAX) :: fish
    integer(kind = 8) :: i, tmp, to_add, total, n_fish, rounds

    do i = 0, MAX
        fish(i) = 0
    end do

    open(1, file = 'input-fortran.txt', status = 'old')
    do i = 1, INPUT_SIZE
        read(1, *) tmp
        fish(tmp) = 1 + fish(tmp)
    end do
    close(1)

    bigloop: do rounds = 1, 256
        to_add = fish(0)
        do i = 1, MAX
            fish(i-1) = fish(i)
        end do
        fish(8) = to_add
        fish(6) = to_add + fish(6)
    end do bigloop

    total = 0

    do i = 0, MAX
        total = fish(i) + total
    end do

    print*, total
end program Lanternfish


      subroutine n1qn1 (simul,n,x,f,g,var,eps,
     1     mode,niter,nsim,imp,lp,zm,izs,rzs,dzs)

c!but
c     minimisation d une fonction reguliere sans contraintes
c
c     direction de descente calculee par une methode de quasi-newton
c     recherche lineaire de type wolfe
c!liste d appel
c     simul    : point d'entree au module de simulation (cf normes modulopt i)
c     n1qn1 appelle toujours simul avec indic = 4 ; le module de
c     simulation doit se presenter sous la forme subroutine simul
c     (n,x, f, g, izs, rzs, dzs) et e^tre declare en external dans le
c     programme appelant n1qn1.
c     n (e)    : nombre de variables dont depend f.
c     x (e-s)   : vecteur de dimension n ; en entree le point initial ;
c                 en sortie : le point final calcule par n1qn1.
c     f (e-s)   : scalaire ; en entree valeur de f en x (initial), en sortie
c                 valeur de f en x (final).
c     g (e-s)   : vecteur de dimension n : en entree valeur du gradient en x
c                 (initial), en sortie valeur du gradient en x (final).
c     var (e)   : vecteur strictement positif de dimension n. amplitude de la
c                 modif souhaitee a la premiere iteration sur x(i).une bonne
c                 valeur est 10% de la difference (en valeur absolue) avec la
c                 coordonee x(i) optimale
c     eps (e-s) : en entree scalaire definit la precision du test d'arret.
c      le programme considere que la convergence est obtenue lorque il lui
c      est impossible de diminuer f en attribuant a au moins une coordonnee
c      x(i) une variation superieure a eps*var(i).
c      en sortie, eps contient le carre de la norme du gradient en x (final).
c     mode (e)     : definit l approximation initiale du hessien
c                  =1 n1qn1 l initialise lui-meme
c                  =2 le hessien est fourni dans zm sous forme compressee (zm
c                     contient les colonnes de la partie inferieure du hessien)
c     niter (e-s)  : en entree nombre maximal d'iterations : en sortie nombre
c                    d'iterations reellement effectuees.
c     nsim (e-s)  : en entree nombre maximal d'appels a simul (c'est a dire
c         avec indic = 4). en sortie le nombre de tels appels reellement faits.
c      imp (e)   : contro^le les messages d'impression :
c                  0 rien n'est imprime
c                  = 1 impressions initiales et finales
c                  = 2 une impression par iteration (nombre d'iterations,
c                      nombre d'appels a simul, valeur courante de f).
c                  >=3 informations supplementaires sur les recherches
c                      lineaires ;
c                      tres utile pour detecter les erreurs dans le gradient.
c      lp (e)    : le numero du canal de sortie, i.e. les impressions
c                  commandees par imp sont faites par write (lp, format).
c     zm     : memoire de travail pour n1qn1 de   dimension n*(n+13)/2.
c     izs,rzs,dzs memoires reservees au simulateur (cf doc)
c
c!
      implicit double precision (a-h,o-z)
      dimension x(n),g(n),var(n),zm(*),izs(*),dzs(*)
      real rzs(*)
      external simul
 1000 format (41h1entree dans n1qn1. dimension du probleme,i4,
     19h,   de zm,i6)
 1003 format (5h mode,i2,7h   eps=,d10.2,9h   niter=,i4,
     16h nsim=,i5,5h imp=,i3)
 1100 format (16h sortie de n1qn1,24h. norme gradient carre =,d15.7)
      if (imp.le.0) go to 10
      nw=n*(13+n)/2
      write (lp,1000) n,nw
      write (lp,1003) mode,eps,niter,nsim,imp
   10 continue
      nd=1+(n*(n+1))/2
      nw=nd+n
      nxa=nw+n
      nga=nxa+n
      nxb=nga+n
      ngb=nxb+n
      call n1qn1a (simul,n,x,f,g,var,eps,mode,
     1 niter,nsim,imp,lp,zm,zm(nd),zm(nw),zm(nxa),zm(nga),
     2 zm(nxb),zm(ngb),izs,rzs,dzs)
      if (imp.gt.0) write (lp,1100) eps
      return
      end


	SUBROUTINE GDXSCV ( w, ponth, wlvls, nx, nv, rlen, ivcord,
     +		   	    iyaxis, ystrt, ystop, aratio, ws, iret )
C************************************************************************
C* GDXSCV								*
C*									*
C* This subroutine scales the vertical component of the cross section	*
C* vector velocity.  The output vector can be the same as the input	*
C* vector.								*
C*									*
C* GDXSCV  ( W, PONTH, WLVLS, NX, NV, RLEN, IVCORD, IYAXIS, YSTRT,	*
C*           YSTOP, ARATIO, WS, IRET )					*
C*									*
C* Input parameters:							*
C*	W     (NX,NV)	REAL		Input array of vert comps	*
C*	PONTH (NX,NV)	REAL		P on theta (ivcord = 2)		*
C*  	WLVLS (NV)	REAL		Vertical levels			*
C*	NX		INTEGER		Number of points in horz	*
C*	NV		INTEGER		Number of points in vert	*
C*	RLEN		REAL		Length of xsectn ( m )		*
C*	IVCORD		INTEGER		Vertical coordinate		*
C*					  1 = PRES			*
C*					  2 = THET			*
C*   					  3 = HGHT			*
C*	IYAXIS		INTEGER		Vertical coordinate type:	*
C*					  1 = linear			*
C*					  2 = logarthmic		*
C*					  3 = ** RKAPPA			*
C*	YSTRT		REAL		Vertical coordinate lower bnd	*
C*	YSTOP		REAL		Vertical coordinate upper bnd	*
C*	ARATIO 		REAL		Aspect ratio of plot		*
C*					  0 = compute aspect ratio	*
C*									*
C* Output parameters:							*
C*	WS    (NX,NV)	REAL		Output scaled vert comps	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -6 = invalid vert coord	*
C*					 -7 = invalid vert axis type 	*
C**									*
C* Log:									*
C* K. Brill/GSC		 7/89  						*
C* M. desJardins/GSFC	 5/90	Cleaned up; declared PONTH		*
C************************************************************************
	INCLUDE 'GEMPRM.PRM'
C*
        REAL 		w (nx,*), ws (nx,*), wlvls (nv), ponth (nx,*)
C*
	REAL		rlvls (LLMXLV)
C*
	INCLUDE 'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	If input aspect ratio is 0, it is computed.
C
	ratio = aratio
	IF  ( ratio .lt. .001 )  THEN
	    CALL GQBND  ( 'P', xl, yb, xr, yt, ire )
	    IF  ( ire .ne. 0 )  THEN
		ratio = 1.0
	      ELSE
		ratio = ABS ( ( yt - yb ) / ( xr - xl ) )
	    END IF
	END IF
C
C*	Compute aspect ratio of plot times length.
C
	al = ratio * rlen
C
C*	Convert vertical coordinate to assumed standard units
C*	corresponding to vertical velocity.  The assumptions are:
C*        1.  When IVCORD = 1, the p coordinate is in mb and the
C*	      vertical motion is dp/dt (omega) in millibars/second.
C*        2.  When IVCORD = 2, the theta coordinate is in K and the
C*	      vertical motion is dp/dt (omega) in millibars/second.
C*	  3.  When IVCORD = 3, the height coordinate is in meters
C*            and the vertical motion is in cm/s.
C
	IF ( ivcord .eq. 1 ) THEN
	    zstrt = ystrt
	    zstop = ystop
	    DO  k = 1, nv
		rlvls ( k ) = wlvls ( k )
	    END DO
	  ELSE IF  ( ivcord .eq. 2 )  THEN
	    zstrt = ystrt
	    zstop = ystop
	    DO  k = 1, nv
		rlvls ( k ) = wlvls ( k )
	    END DO
	  ELSE IF ( ivcord .eq. 3 ) THEN
	    zstrt = ystrt * 100.0
	    zstop = ystop * 100.0
	    DO  k = 1, nv
		rlvls ( k ) = wlvls ( k ) * 100.0
	    END DO
	  ELSE
	    iret = -6
	    RETURN
	END IF
C
C*	Compute constant part of scale factor.
C
	IF  ( iyaxis .eq. 1 )  THEN
	    conf = al / ( zstop - zstrt )
	  ELSE IF  ( iyaxis .eq. 2 )  THEN
	    IF  ( ( zstop .le. 0.0 ) .or. ( zstrt .le. 0.0 ) )  THEN
		iret = -7
		RETURN
	    END IF
	    conf = al / ALOG ( zstop / zstrt )
	  ELSE IF ( iyaxis .eq. 3 ) THEN
	    IF  ( ( zstop .le. 0.0 ) .or. ( zstrt .le. 0.0 ) )  THEN
		iret = -7
		RETURN
	    END IF
	    rkpm1 = RKAPPA - 1.
	    conf = al / ( zstop ** RKAPPA - zstrt ** RKAPPA )
	  ELSE
		iret = -7
		RETURN
	END IF
C
C*	Do the scaling at all the levels.
C
	DO k = 1, nv
	    IF ( iyaxis .eq. 1 ) THEN
		scale = conf
	      ELSE IF ( iyaxis .eq. 2 ) THEN
		scale = conf / rlvls ( k )
	      ELSE IF ( iyaxis .eq. 3 ) THEN
		scale = conf * RKAPPA * rlvls ( k ) ** rkpm1
	    END IF
C*
	    DO  i = 1, nx
		IF  ( ivcord .eq. 2 )  THEN
		    IF ( ERMISS ( ponth ( i, k ) ) .or.
     +			 ERMISS ( w ( i, k ) ) )  THEN
			ws ( i, k ) = RMISSD
		      ELSE
			scale = (-scale) * RKAPPA *
     +				 rlvls ( k ) / ponth ( i, k )
			ws ( i, k ) = scale * w ( i, k )
		    END IF
		  ELSE IF ( ERMISS ( w ( i, k ) ) ) THEN
		    ws ( i, k ) = RMISSD
		  ELSE
		    ws ( i, k ) = scale * w ( i, k )
		END IF
	    END DO
	END DO
C*
	RETURN
	END


!-----------------------------------------------------------------------
!     Subroutine:    chisq_rosenbrock
!     Authors:       J. Schmitt (jschmitt@pppl.gov)
!     Date:          2019
!     Description:   This is a chisq subroutine for a Rosenbrock-like
!                    test function.  It does not depend on any equlibrium
!                    values.
!-----------------------------------------------------------------------
      SUBROUTINE chisq_rosenbrock(target,sigma,niter,iflag)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stellopt_runtime
      USE stellopt_targets
      USE stellopt_vars

!-----------------------------------------------------------------------
!     Input/Output Variables
!
!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL(rprec), INTENT(in)    ::  target(rosenbrock_dim)
      REAL(rprec), INTENT(in)    ::  sigma(rosenbrock_dim)
      INTEGER,     INTENT(in)    ::  niter
      INTEGER,     INTENT(inout) ::  iflag

!-----------------------------------------------------------------------
!     Local Variables
!
!-----------------------------------------------------------------------
      INTEGER :: ii
      REAL(rprec)  :: Rosenbrock_F
!----------------------------------------------------------------------
!     BEGIN SUBROUTINE
!----------------------------------------------------------------------
      IF (iflag < 0) RETURN
      IF (iflag == 1) WRITE(iunit_out,'(A,2(2X,I3.3))') 'Rosenbrock_X',1,3
      IF (iflag == 1) WRITE(iunit_out,'(A)') 'TARGET  SIGMA  XVAL'
      IF (niter >= 0) THEN
         ! Now fill in the targets, sigmas and chi_sq
         DO ii = 1, rosenbrock_dim
            !IF (sigma(ii) >= bigno) CYCLE
            IF (sigma(ii) < bigno) THEN
               mtargets = mtargets + 1
               targets(mtargets) = target(ii)
               sigmas(mtargets)  = sigma(ii)
               ! Fill in vals with the Rosenbrock function values
               if (ii .eq. 1) THEN
                  Rosenbrock_F = 1.0 * (1.0 - Rosenbrock_X(ii))
               elseif (ii .gt. 1) THEN
                  ! Rosenbrock_F = 10.0 * (Rosenbrock_X(ii) - (Rosenbrock_X(ii-1))**2)
                  Rosenbrock_F = 10.0 * (Rosenbrock_X(ii) - Rosenbrock_X(ii-1)**2)
               END IF
               vals(mtargets)    = Rosenbrock_F
               IF (iflag == 1) WRITE(iunit_out,'(3ES22.12E3)') target,sigma,vals(mtargets)
            END IF
         END DO
      ELSE
         IF (ANY(sigma < bigno)) THEN
            ! Fill in the targets
            DO ii = 1, rosenbrock_dim
               IF (sigma(ii) < bigno) THEN
                  mtargets = mtargets + 1
                  IF (niter == -2) THEN
                     target_dex(mtargets)=jtarget_Rosenbrock_F
                  END IF
               END IF
            END DO
         END IF
      END IF
      RETURN
!----------------------------------------------------------------------
!     END SUBROUTINE
!----------------------------------------------------------------------
      END SUBROUTINE chisq_Rosenbrock


MODULE Canopytemperaturemod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_canopytemperature(minTair, &
        maxTair, &
        cropHeatFlux, &
        conductance, &
        lambdaV, &
        rhoDensityAir, &
        specificHeatCapacityAir, &
        minCanopyTemperature, &
        maxCanopyTemperature)
        IMPLICIT NONE
        REAL, INTENT(IN) :: minTair
        REAL, INTENT(IN) :: maxTair
        REAL, INTENT(IN) :: cropHeatFlux
        REAL, INTENT(IN) :: conductance
        REAL, INTENT(IN) :: lambdaV
        REAL, INTENT(IN) :: rhoDensityAir
        REAL, INTENT(IN) :: specificHeatCapacityAir
        REAL, INTENT(OUT) :: minCanopyTemperature
        REAL, INTENT(OUT) :: maxCanopyTemperature
        !- Description:
    !            * Title: CanopyTemperature Model
    !            * Author: Pierre Martre
    !            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    !            Evapotranspiration and canopy and soil temperature calculations
    !            * Institution: INRA/LEPSE Montpellier
    !            * Abstract: It is calculated from the crop heat flux and the boundary layer conductance
        !- inputs:
    !            * name: minTair
    !                          ** description : minimum air temperature
    !                          ** datatype : DOUBLE
    !                          ** variablecategory : auxiliary
    !                          ** min : -30
    !                          ** max : 45
    !                          ** default : 0.7
    !                          ** unit : degC
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: maxTair
    !                          ** description : maximum air Temperature
    !                          ** datatype : DOUBLE
    !                          ** variablecategory : auxiliary
    !                          ** min : -30
    !                          ** max : 45
    !                          ** default : 7.2
    !                          ** unit : degC
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : variable
    !            * name: cropHeatFlux
    !                          ** description : Crop heat flux
    !                          ** variablecategory : rate
    !                          ** inputtype : variable
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 447.912
    !                          ** unit : g/m**2/d
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            * name: conductance
    !                          ** description : the boundary layer conductance
    !                          ** variablecategory : state
    !                          ** inputtype : variable
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** default : 598.685
    !                          ** unit : m/d
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            * name: lambdaV
    !                          ** description : latent heat of vaporization of water
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 2.454
    !                          ** min : 0
    !                          ** max : 10
    !                          ** unit : MJ/kg
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: rhoDensityAir
    !                          ** description : Density of air
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 1.225
    !                          ** unit : kg/m**3
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
    !            * name: specificHeatCapacityAir
    !                          ** description : Specific heat capacity of dry air
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.00101
    !                          ** unit : MJ/kg/degC
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !                          ** inputtype : parameter
        !- outputs:
    !            * name: minCanopyTemperature
    !                          ** description : minimal Canopy Temperature
    !                          ** datatype : DOUBLE
    !                          ** variablecategory : state
    !                          ** min : -30
    !                          ** max : 45
    !                          ** unit : degC
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    !            * name: maxCanopyTemperature
    !                          ** description : maximal Canopy Temperature
    !                          ** datatype : DOUBLE
    !                          ** variablecategory : state
    !                          ** min : -30
    !                          ** max : 45
    !                          ** unit : degC
    !                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
        minCanopyTemperature = minTair + (cropHeatFlux / (rhoDensityAir *  &
                specificHeatCapacityAir * conductance / lambdaV * 1000.0))
        maxCanopyTemperature = maxTair + (cropHeatFlux / (rhoDensityAir *  &
                specificHeatCapacityAir * conductance / lambdaV * 1000.0))
    END SUBROUTINE model_canopytemperature

END MODULE


c /***************************************************
c   expdgen.f  for dbulhalo
c  11 June. 2015  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   generating exponential disk *****/
      subroutine expdgen(id,nd,mtdisk,mdisk,hd,zd0,rdlim,zdlim
     &   ,ngr,ngz,flagb
     &   ,omg0,omz,hub,cnfw,rvir,zt,fb,flagmexth
     &   ,flagflzd,Rflzd)
      include 'define.f'

      integer nd,id,flagb,flagflzd
      integer ngr,ngz
      character filen*60
      double precision mtdisk,mdisk,hd,zd0,rdlim,zdlim,Rflzd
      integer i,j
      integer nrp,ndrm
      double precision ri,ro,lri,lro,dlr,rp,mdp,rr,mrp,zdr
      double precision pfr,ph
c *** Exp disk profile ***
      double precision mrexpd(MNR),rexpd(MNR)
      double precision mzexpd(MNR),zexpd(MNR)
c *** for particles ***
      double precision xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp
c *** for velocity ***
      integer ir,iz
      integer pnrizi,pnrizo,pnrozi,pnrozo
      double precision wrizi,wrizo,wrozi,wrozo
      double precision zp,dr,dz
      double precision vsigz,vsigr,vsigph,vphm
      double precision vrp,vphp
c for NFW halo parameter
      integer flagmexth
      double precision omg0,omz,hub,cnfw,rvir,zt,fb
      double precision rhoc,delc,rs
      double precision fvesc,vesc2r,v2p,r3dp

c *** external function ***
      double precision mrexpdf
      external mrexpdf
      double precision rhonfwsw,mrnfw
      external rhonfwsw,mrnfw
c *** external function
      integer idum
      real ran1,gasdev
      external ran1,gasdev

      idum = -111+id

c NFW profile constant
      rhoc = (3.0d0*HUB0*HUB0*hub*hub/(8.0d0*M_PI*G))
     &  *(omg0/omz)*((1.0d0+zt)**3)
      delc = (200.0d0/3.0d0)*(cnfw**3/(dlog(1.0d0+cnfw)
     &  -cnfw/(1.0d0+cnfw)))
      rs=rvir/cnfw
c escape velocity constant from BT2nd p.71
      fvesc=2.0d0*4.0d0*M_PI*G*(1.0d0-fb)*delc*rhoc*(rs**2)
      r3dp=0.1d0
      if(myrank.eq.0) then
        write(6,*) ' rhoc,delc,fb=',rhoc,delc,fb
        write(6,*) ' esc velocity at 10 kpc=',VUKMS*dsqrt(fvesc
     &    *dlog(1.0d0+r3dp/rs)/(r3dp/rs))
      endif

      ri = 1.0e-6*rdlim
      ro = rdlim
      lri = dlog10(ri)
      lro = dlog10(ro)
      dlr = (lro-lri)/dble(ndr-1)
c *** set mr and r ***
      rexpd(1) = 0.0d0
      mrexpd(1) = 0.0d0
      do i=1,ndr
        rexpd(i) = 10.0d0**(lri+dlr*dble(i-1))
        rr = rexpd(i)
c        mrexpd(i) = 1.0d0-(1.0d0+rr/hd)*dexp(-rr/hd)
        mrexpd(i)=mrexpdf(rr,hd,mtdisk)/mdisk
      enddo
c *** set mz and z ***
      ri = 1.0e-7*zdlim
      ro = zdlim
      lri = dlog10(ri)
      lro = dlog10(ro)
      dlr = (lro-lri)/dble(ndr-1)
c *** set mr and r ***
      do i=1,ndr
        zexpd(i) = 10.0d0**(lri+dlr*dble(i-1))
        rr = zexpd(i)
c Integral sech(z/zd)^2 is zd tanh(z/zd)
        mzexpd(i) = dtanh(rr/zd0)
      enddo
      mdp = mdisk/dble(nd)

      write(6,*) id,' disk particle mass=',mdp

c *** generating particles ***
      write(filen,'(a12,i1,a4)') 'output/diskc',id,'.dat'
      if(flagb.eq.0) then
        open(60,file=filen,status='unknown',form='unformatted')
        write(60) nd,0
      else
        open(60,file=filen,status='unknown')
        write(60,'(a8,2I8)') '#n,flag=',nd,0
      endif

      do i=0,nd-1
 67     pfr = dble(ran1(idum))
c /*** search radius ***/
        do j=1,ndr
          if(mrexpd(j).gt.pfr) then
            goto 72
          endif
        enddo
c        write(6,*) ' Warning: in finding radius for disk'
c        write(6,*) '  pfr =',pfr
        goto 67
 72     if(j.eq.1) then
c          write(6,*) ' Warning: in finding radius for disk: j,mr,prf='
c     &      ,j,mrexpd(j),pfr
          j = 2
        endif
        rp=10.0d0**(dlog10(rexpd(j-1))
     &    +(dlog10(rexpd(j))-dlog10(rexpd(j-1)))
     &    *(dlog10(pfr)-dlog10(mrexpd(j-1)))
     &    /(dlog10(mrexpd(j))-dlog10(mrexpd(j-1))))
        ph =  2.0d0*M_PI*dble(ran1(idum))
        mbp = mdp
        xbp = rp*dcos(ph)
        ybp = rp*dsin(ph)
c *** z-axis ****
 66     pfr = dble(ran1(idum))
c /*** search z ***/
        do j=1,ndr
          if(mzexpd(j).gt.pfr) then
            goto 73
          endif
        enddo
c        write(6,*) ' Warning: in finding z for disk'
c        write(6,*) '  pfr =',pfr
        goto 66
 73     if(j.eq.1) then
c          write(6,*) ' Warning: in finding z for disk: j=1,mz,prf'
c     &    ,mzexpd(j),pfr
          j = 2
        endif
        zbp = 10.0d0**(dlog10(zexpd(j-1))
     &    +(dlog10(zexpd(j))-dlog10(zexpd(j-1)))
     &    *(dlog10(pfr)-dlog10(mzexpd(j-1)))
     &    /(dlog10(mzexpd(j))-dlog10(mzexpd(j-1))))
        if(flagflzd.ne.0) then
c z for scale-height zd0, with zdr z2=zdr z1/zd1
          zbp=zbp*exp(rp/Rflzd)
          zdr=zd0*exp(rp/Rflzd)
        else
          zdr=zd0
        endif
c *** absolute value of z
        zp=zbp
        if(dble(ran1(idum)).lt.0.5d0) then
          zbp=-zbp
        endif
c *** density ***
        rhobp=(mtdisk/(4.0d0*M_PI*zdr*(hd**2)))
     &    *(1.0d0/(dcosh(zbp/zdr)**2))
     &    *dexp(-rp/hd)
c *** velocity ***
c *** find the point in r_rzg ***
        if(rp.gt.0.0d0) then
          ir=int((dlog10(rp)-lri_rzg)/dlr_rzg)+1
        else
          ir=0
        endif
        if(ir.lt.0) then
          ir=0
        else if(ir.gt.ngr-1) then
          ir=ngr-1
        endif
c *** find the point in z_rzg ***
        if(zp.gt.0.0d0) then
          iz=int((dlog10(zp)-lzi_rzg)/dlz_rzg)+1
        else
          iz=0
        endif
        if(iz.lt.0) then
          iz=0
        else if(iz.gt.ngz-1) then
          iz=ngz-1
        endif
c *** grid ***
        pnrizi=id_rzg(ir,iz)
        pnrizo=id_rzg(ir,iz+1)
        pnrozi=id_rzg(ir+1,iz)
        pnrozo=id_rzg(ir+1,iz+1)
        dr=x_rzg(pnrozi)-x_rzg(pnrizi)
        dz=z_rzg(pnrizo)-z_rzg(pnrizi)
c weight
        wrizi=(x_rzg(pnrozi)-rp)*(z_rzg(pnrizo)-zp)/(dr*dz)
        wrizo=(x_rzg(pnrozo)-rp)*(zp-z_rzg(pnrizi))/(dr*dz)
        wrozi=(rp-x_rzg(pnrizi))*(z_rzg(pnrozo)-zp)/(dr*dz)
        wrozo=(rp-x_rzg(pnrizo))*(zp-z_rzg(pnrozi))/(dr*dz)
c *** vphm
        vphm=wrizi*vph_rzg(pnrizi)+wrizo*vph_rzg(pnrizo)
     &   +wrozi*vph_rzg(pnrozi)+wrozo*vph_rzg(pnrozo)
        if(vphm.lt.0.0d0) then
          vphm=0.0d0
        endif
c *** vsigph
        vsigph=wrizi*vsigph_rzg(pnrizi)+wrizo*vsigph_rzg(pnrizo)
     &   +wrozi*vsigph_rzg(pnrozi)+wrozo*vsigph_rzg(pnrozo)
        if(vsigph.lt.0.0d0) then
          vsigph=0.0d0
        endif
c *** vsigr
        vsigr=wrizi*vsigr_rzg(pnrizi)+wrizo*vsigr_rzg(pnrizo)
     &   +wrozi*vsigr_rzg(pnrozi)+wrozo*vsigr_rzg(pnrozo)
        if(vsigr.lt.0.0d0) then
          vsigr=0.0d0
        endif
c *** vsigz
        vsigz=wrizi*vsigz_rzg(pnrizi)+wrizo*vsigz_rzg(pnrizo)
     &   +wrozi*vsigz_rzg(pnrozi)+wrozo*vsigz_rzg(pnrozo)
        if(vsigz.lt.0.0d0) then
          vsigz=0.0d0
        endif
c *** get vph,vr,vz
 74     vphp=vphm+vsigph*dble(gasdev(idum))
        vrp=vsigr*dble(gasdev(idum))
        vzbp=vsigz*dble(gasdev(idum))
c *** convert vr,vph -> vx,vy ***
        if(rp.gt.0.0d0) then
          vxbp=vrp*xbp/rp-vphp*ybp/rp
          vybp=vrp*ybp/rp+vphp*xbp/rp
        else
          vxbp=0.0d0
          vybp=0.0d0
        endif
c check escape velocity (from Halo)
        if(flagmexth.le.1) then
          r3dp=dsqrt(xbp**2+ybp**2+zbp**2)
          vesc2r=fvesc*dlog(1.0d0+r3dp/rs)/(r3dp/rs)
          v2p=vxbp**2+vybp**2+vzbp**2
          if(v2p.gt.vesc2r) then
            goto 74
          endif
c escape velocity
        endif

c *** output
        if(flagb.eq.0) then
          write(60) xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp
        else
          write(60,160) xbp,ybp,zbp,vxbp,vybp,vzbp,mbp,rhobp
     &     ,dsqrt(v2p),dsqrt(vesc2r),dsqrt(xbp**2+ybp**2)
 160      format(11(1pE13.5))
        endif
      enddo
      close(60)

      return
      end


      SUBROUTINE getbrho (brhomn, frho, bsupu, bsupv, mmax, nmax, info)
      USE stel_kinds
      USE vmec_input, ONLY: nfp, nzeta, lasym
      USE vmec_dim, ONLY: ntheta1, ntheta2, ntheta3
      USE vmec_persistent, ONLY: cosmu, sinmu, cosnv, sinnv
      USE vmec_main, ONLY: r0scale
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: mmax, nmax
      INTEGER, INTENT(out) :: info
      REAL(rprec), INTENT(out) :: brhomn(0:mmax, -nmax:nmax, 0:1)
      REAL(rprec), DIMENSION(nzeta, ntheta3), INTENT(in) ::
     1    bsupu, bsupv, frho
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: p5 = 0.5_dp, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: i, j, m, n, nmax1, itotal, ijtot, mntot
      REAL(rprec) :: ccmn, ssmn, csmn, scmn, dm, dn, termsc, termcs,
     `               termcc, termss, amn
      REAL(rprec), ALLOCATABLE :: amatrix(:,:), save_matrix(:,:),
     1   brhs(:)
      LOGICAL :: lpior0
      EXTERNAL solver
C-----------------------------------------------
!
!     Solves the radial force balance B dot Brho = Fs for Brho in real space using collocation
!     Here, Fs = frho(mn) is the Fourier transform SQRT(g)*F (part of radial force
!     balance sans the B dot Brho term)
!
!     Storage layout: brhomn(0:mmax, 0:nmax,0) :: coefficient of sin(mu)cos(nv)
!                     brhomn(0:mmax,-1:nmax,0) :: coefficient of cos(mu)sin(nv)
!     for lasym = T
!                     brhomn(0:mmax, 0:nmax,1) :: coefficient of cos(mu)cos(nv)
!                     brhomn(0:mmax,-1:nmax,1) :: coefficient of sin(mu)sin(nv)
!
!     where 0<=m<=mmax and 0<=n<=nmax
!
      info = -3
      IF ((mmax+1 .ne. ntheta2) .or. (nmax .ne. nzeta/2)) RETURN

      nmax1 = MAX(0,nmax-1)
      itotal = ntheta3*nzeta
      IF (.not.lasym) itotal = itotal - 2*nmax1
      ALLOCATE (amatrix(itotal, itotal),
     1      brhs(itotal), save_matrix(itotal, itotal), stat=m)
      IF (m .ne. 0) STOP 'Allocation error in getbrho'

      amatrix = 0

!
!     BRHO = BSC(M,N)*SIN(MU)COS(NV) + BCS(M,N)*COS(MU)SIN(NV)
!          + BCC(M,N)*COS(MU)COS(NV) + BSS(M,N)*SIN(MU)SIN(NV)   (LASYM=T ONLY)
!

      ijtot = 0
      brhs = 0

      DO i = 1, ntheta3
         DO j = 1, nzeta
!           IGNORE u=0,pi POINTS FOR v > pi: REFLECTIONAL SYMMETRY
            lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1))
            IF (lpior0 .and. .not. lasym) CYCLE
            ijtot = ijtot + 1
            brhs(ijtot) = frho(j,i)
            mntot = 0
            DO m = 0, mmax
               DO n = 0, nmax
                  IF (mntot .ge. itotal) EXIT
                  IF (m.eq.0 .and. n.eq.0 .and. lasym) CYCLE
                  mntot = mntot+1
                  ccmn = cosmu(i,m)*cosnv(j,n)
                  ssmn = sinmu(i,m)*sinnv(j,n)
                  dm = m * bsupu(j,i)
                  dn = n * bsupv(j,i) * nfp
                  termsc = dm*ccmn - dn*ssmn
                  termcs =-dm*ssmn + dn*ccmn
                  IF (n.eq.0 .or. n.eq.nmax) THEN
                     IF (m .gt. 0) THEN
                        amatrix(ijtot,mntot) = termsc     !!ONLY bsc != 0 for n=0, nmax1
                     ELSE IF (n .eq. 0) THEN
                        amatrix(ijtot,mntot) = bsupv(j,i) !!pedestal for m=0,n=0 mode, which should = 0
                     ELSE
                        amatrix(ijtot,mntot) = termcs     !!bcs(m=0,n=nmax)
                     END IF
                  ELSE IF (m.eq.0 .or. m.eq.mmax) THEN
                     amatrix(ijtot,mntot) = termcs        !!ONLY bcs != 0 for m=0,mmax
                  ELSE
                     amatrix(ijtot,mntot) = termsc
                     mntot = mntot+1
                     amatrix(ijtot,mntot) = termcs
                  END IF

                  IF (.not.lasym) CYCLE
                  IF (m.eq.0 .and. (n.eq.0 .or. n.eq.nmax)) CYCLE

                  IF (mntot .ge. itotal) EXIT
                  mntot = mntot+1
                  csmn = cosmu(i,m)*sinnv(j,n)
                  scmn = sinmu(i,m)*cosnv(j,n)
                  termcc =-dm*scmn - dn*csmn
                  termss = dm*csmn + dn*scmn

                  IF ((n.eq.0 .or. n.eq.nmax) .or.
     1                (m.eq.0 .or. m.eq.mmax)) THEN
                      amatrix(ijtot,mntot) = termcc    !!ONLY bcc != 0 for m=0 or mmax
                  ELSE
                     amatrix(ijtot,mntot) = termcc
                     mntot = mntot+1
                     amatrix(ijtot,mntot) = termss
                  END IF

               END DO
            END DO
         END DO
      END DO

      save_matrix = amatrix

      info = -1
      IF (ijtot .ne. itotal .or. mntot .ne. itotal) THEN
         PRINT *,' itotal = ', itotal,' ijtot = ', ijtot,
     1   ' mntot = ', mntot
         PRINT *,' ntheta3: ',ntheta3,' nzeta: ', nzeta,
     1           ' mnyq: ', mmax,' nnyq: ', nmax
         GOTO 200
      ELSE
         CALL solver (amatrix, brhs, itotal, 1, info)
         IF (info .ne. 0) GOTO 200
      END IF

!
!     CHECK SOLUTION FROM SOLVER
!
!      GOTO 100
      ijtot = 0
      DO i = 1, ntheta3
         DO j = 1, nzeta
            lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1))
            IF (lpior0 .and. .not.lasym) CYCLE
            ijtot = ijtot + 1
            amn = SUM(save_matrix(ijtot,:)*brhs(:))
            IF (ABS(amn) .lt. 1.E-12_dp) CYCLE
            IF (ABS(frho(j,i) - amn) .gt. 1.e-8_dp*ABS(amn)) THEN
               PRINT 50,'In GETBRHO, i = ',i,' j = ',j,
     1         ' Original force = ', frho(j,i),' Final force = ', amn
            END IF
        END DO
      END DO
  50  FORMAT(a,i5,a,i5,a,1p,e10.3,a,1p,e10.3)
 100  CONTINUE
!
!     CONVERT BACK TO BS*SIN(MU - NV) REPRESENTATION
!     AND (FOR lasym) BC*COS(MU - NV)
!
      mntot = 0
      brhomn = 0
      DO m = 0, mmax
         DO n = 0, nmax
            IF (mntot .ge. itotal) EXIT
            IF (m.eq.0 .and. n.eq.0 .and. lasym) CYCLE
            mntot = mntot+1
            IF (n.eq.0 .or. n.eq.nmax) THEN
               IF (m .gt. 0) THEN
                  brhomn(m,n,0) = brhs(mntot)
               ELSE IF (n .eq. 0) THEN
                  brhomn(m,n,0) = brhs(mntot)
               ELSE
                  brhomn(m,-n,0) = brhs(mntot)
               END IF
            ELSE IF (m.eq.0 .or. m.eq.mmax) THEN
               brhomn(m,-n,0) = brhs(mntot)
            ELSE
               brhomn(m,n,0) = brhs(mntot)
               mntot = mntot+1
               brhomn(m,-n,0) = brhs(mntot)
            END IF

            IF (.not.lasym) CYCLE
            IF (m.eq.0 .and. (n.eq.0 .or. n.eq.nmax)) CYCLE
            IF (mntot .ge. itotal) EXIT
            mntot = mntot+1

            IF ((n.eq.0 .or. n.eq.nmax) .or.
     1          (m.eq.0 .or. m.eq.mmax)) THEN
               brhomn(m,n,1) = brhs(mntot)
            ELSE
               brhomn(m,n,1) = brhs(mntot)
               mntot = mntot+1
               brhomn(m,-n,1)= brhs(mntot)
            END IF

         END DO
      END DO

      IF (mntot .ne. ijtot) info = -2

 200  CONTINUE

      DEALLOCATE (amatrix, save_matrix, brhs)

      END SUBROUTINE getbrho


      SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q,
     $                   LDQ, R, LDR, JPVT, TOL1, TOL2, 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 a low rank QR factorization with column pivoting of a
C     K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L);
C     specifically,
C                                     T
C                           T P =  Q R ,
C
C     where R is lower trapezoidal, P is a block permutation matrix
C     and Q^T Q = I. The number of columns in R is equivalent to the
C     numerical rank of T with respect to the given tolerance TOL1.
C     Note that the pivoting scheme is local, i.e., only columns
C     belonging to the same block in T are permuted.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine as follows:
C             = 'Q':  computes Q and R;
C             = 'R':  only computes R.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows in one block of T.  K >= 0.
C
C     L       (input)  INTEGER
C             The number of columns in one block of T.  L >= 0.
C
C     M       (input)  INTEGER
C             The number of blocks in one block column of T.  M >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in one block row of T.  N >= 0.
C
C     TC      (input) DOUBLE PRECISION array, dimension (LDTC, L)
C             The leading M*K-by-L part of this array must contain
C             the first block column of T.
C
C     LDTC    INTEGER
C             The leading dimension of the array TC.
C             LDTC >= MAX(1,M*K).
C
C     TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
C             The leading K-by-(N-1)*L part of this array must contain
C             the first block row of T without the leading K-by-L
C             block.
C
C     LDTR    INTEGER
C             The leading dimension of the array TR.  LDTR >= MAX(1,K).
C
C     RNK     (output)  INTEGER
C             The number of columns in R, which is equivalent to the
C             numerical rank of T.
C
C     Q       (output)  DOUBLE PRECISION array, dimension (LDQ,RNK)
C             If JOB = 'Q', then the leading M*K-by-RNK part of this
C             array contains the factor Q.
C             If JOB = 'R', then this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= MAX(1,M*K),  if JOB = 'Q';
C             LDQ >= 1,           if JOB = 'R'.
C
C     R       (output)  DOUBLE PRECISION array, dimension (LDR,RNK)
C             The leading N*L-by-RNK part of this array contains the
C             lower trapezoidal factor R.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1,N*L)
C
C     JPVT    (output)  INTEGER array, dimension (MIN(M*K,N*L))
C             This array records the column pivoting performed.
C             If JPVT(j) = k, then the j-th column of T*P was
C             the k-th column of T.
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If TOL1 >= 0.0, the user supplied diagonal tolerance;
C             if TOL1 < 0.0, a default diagonal tolerance is used.
C
C     TOL2    DOUBLE PRECISION
C             If TOL2 >= 0.0, the user supplied offdiagonal tolerance;
C             if TOL2 < 0.0, a default offdiagonal tolerance is used.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK;  DWORK(2) and DWORK(3) return the used values
C             for TOL1 and TOL2, respectively.
C             On exit, if INFO = -19,  DWORK(1) returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L
C                                 + MAX(M*K,(N-1)*L) ),    if JOB = 'Q';
C             LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L,
C                                 M*K*( L + 1 ) + L ),     if JOB = 'R'.
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:  due to perturbations induced by roundoff errors, or
C                   removal of nearly linearly dependent columns of the
C                   generator, the Schur algorithm encountered a
C                   situation where a diagonal element in the negative
C                   generator is larger in magnitude than the
C                   corresponding diagonal element in the positive
C                   generator (modulo TOL1);
C             = 2:  due to perturbations induced by roundoff errors, or
C                   removal of nearly linearly dependent columns of the
C                   generator, the Schur algorithm encountered a
C                   situation where diagonal elements in the positive
C                   and negative generator are equal in magnitude
C                   (modulo TOL1), but the offdiagonal elements suggest
C                   that these columns are not linearly dependent
C                   (modulo TOL2*ABS(diagonal element)).
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C     If, during the process, the hyperbolic norm of a row in the
C     leading part of the generator is found to be less than or equal
C     to TOL1, then this row is not reduced. If the difference of the
C     corresponding columns has a norm less than or equal to TOL2 times
C     the magnitude of the leading element, then this column is removed
C     from the generator, as well as from R. Otherwise, the algorithm
C     breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set
C     to N*L*sqrt(eps) by default.
C     If M*K > L, the columns of T are permuted so that the diagonal
C     elements in one block column of R have decreasing magnitudes.
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0(K*RNK*L*M*N) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001.
C     D. Kressner, Technical Univ. Berlin, Germany, July 2002.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N,
     $                  RNK
      DOUBLE PRECISION  TOL1, TOL2
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*),
     $                  TR(LDTR,*)
      INTEGER           JPVT(*)
C     .. Local Scalars ..
      LOGICAL           COMPQ, LAST
      INTEGER           CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK,
     $                  NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF,
     $                  RRDF, RRNK, WRKMIN, WRKOPT
      DOUBLE PRECISION  LTOL1, LTOL2, NRM, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DNRM2
      EXTERNAL          DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET,
     $                  DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU,
     $                  MB02CV, MB02KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO   = 0
      WRKOPT = 3
      MK     = M*K
      COMPQ  = LSAME( JOB, 'Q' )
      IF ( COMPQ ) THEN
         WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L +
     $                    MAX( MK, ( N - 1 )*L ) )
      ELSE
         WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L,
     $                    MK*( L + 1 ) + L ) )
      END IF
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN
         INFO = -1
      ELSE IF ( K.LT.0 ) THEN
         INFO = -2
      ELSE IF ( L.LT.0 ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN
         INFO = -7
      ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN
         INFO = -9
      ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN
         INFO = -12
      ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN
         INFO = -14
      ELSE IF ( LDWORK.LT.WRKMIN ) THEN
         DWORK(1) = DBLE( WRKMIN )
         INFO = -19
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02JX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( M, N, K, L ).EQ.0 ) THEN
         RNK      = 0
         DWORK(1) = DBLE( WRKOPT )
         DWORK(2) = ZERO
         DWORK(3) = ZERO
         RETURN
      END IF
C
      WRKOPT = WRKMIN
C
      IF ( MK.LE.L ) THEN
C
C        Catch M*K <= L.
C
         CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK )
         PDW   = MK*L + 1
         JWORK = PDW  + MK
         CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR )
         CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IF ( COMPQ )
     $      CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ )
         PDW = MK*MK + 1
         IF ( N.GT.1 ) THEN
            CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE,
     $                   ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1),
     $                   LDR, DWORK(PDW), LDWORK-PDW+1, IERR )
         END IF
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
         DO 10  I = 1, MK
            JPVT(I) = I
   10    CONTINUE
C
         RNK      = MK
         DWORK(1) = DBLE( WRKOPT )
         DWORK(2) = ZERO
         DWORK(3) = ZERO
         RETURN
      END IF
C
C     Compute the generator:
C
C     1st column of the generator.
C
      DO 20  I = 1, L
         JPVT(I) = 0
   20 CONTINUE
C
      LTOL1 = TOL1
      LTOL2 = TOL2
C
      IF ( COMPQ ) THEN
         CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ )
         CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1),
     $                LDWORK-L, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L )
C
         IF ( LTOL1.LT.ZERO ) THEN
C
C           Compute default tolerance LTOL1.
C
C           Estimate the 2-norm of the first block column of the
C           matrix with 5 power iterations.
C
            TEMP = ONE / SQRT( DBLE( L ) )
            CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 )
C
            DO 30  I = 1, 5
               CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q,
     $                     LDQ, DWORK(L+1), 1 )
               CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ,
     $                     DWORK(L+1), 1 )
               NRM = DNRM2( L, DWORK(L+1), 1 )
               CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 )
   30       CONTINUE
C
            LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) )
         END IF
C
         I = L
C
   40    CONTINUE
         IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN
            I = I - 1
            IF ( I.GT.0 )  GO TO 40
         END IF
C
         RRNK = I
         RRDF = L - RRNK
         CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR )
         IF ( RRNK.GT.1 )
     $      CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR )
         CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L,
     $                IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L )
         IF ( N.GT.1 ) THEN
            CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE,
     $                   ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1),
     $                   LDR, DWORK, LDWORK, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
         END IF
C
      ELSE
C
         PDW   = MK*L + 1
         JWORK = PDW  + L
         CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK )
         CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
         IF ( LTOL1.LT.ZERO ) THEN
C
C           Compute default tolerance LTOL1.
C
C           Estimate the 2-norm of the first block column of the
C           matrix with 5 power iterations.
C
            TEMP = ONE / SQRT( DBLE( L ) )
            CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 )
C
            DO 50  I = 1, 5
               CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK,
     $                     MK, DWORK(JWORK), 1 )
               CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK,
     $                     MK, DWORK(JWORK), 1 )
               NRM = DNRM2( L, DWORK(JWORK), 1 )
               CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 )
   50       CONTINUE
C
            LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) )
         END IF
C
         RRNK = L
         I = ( L - 1 )*MK + L
C
   60    CONTINUE
         IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN
            RRNK = RRNK - 1
            I = I - MK - 1
            IF ( I.GT.0 )  GO TO 60
         END IF
C
         RRDF = L - RRNK
         CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR )
         IF ( RRNK.GT.1 )
     $      CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR )
         CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         IF ( N.GT.1 ) THEN
            CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE,
     $                   ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1),
     $                   LDR, DWORK(PDW), LDWORK-PDW+1, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
         END IF
      END IF
C
C     Quick return if N = 1.
C
      IF ( N.EQ.1 ) THEN
         RNK      = RRNK
         DWORK(1) = DBLE( WRKOPT )
         DWORK(2) = LTOL1
         DWORK(3) = ZERO
         RETURN
      END IF
C
C     Compute default tolerance LTOL2.
C
      IF ( LTOL2.LT.ZERO )
     $   LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) )
C
      DO 70  J = 1, L
         CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR )
   70 CONTINUE
C
      IF ( N.GT.2 )
     $   CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR,
     $                R(2*L+1,RRNK+1), LDR )
C
C     2nd column of the generator.
C
      IF ( RRDF.GT.0 )
     $   CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR,
     $                R(L+1,2*RRNK+1), LDR )
      IF ( K.GT.RRDF )
     $   CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK,
     $                (N-1)*L )
C
C     3rd column of the generator.
C
      PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1
      CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR),
     $             (N-1)*L )
C
C     4th column of the generator.
C
      PDW = PNR + ( N - 1 )*L*RRNK
      PT  = ( M - 1 )*K + 1
C
      DO 80  I = 1, MIN( M, N-1 )
         CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L )
         PT  = PT  - K
         PDW = PDW + L
   80 CONTINUE
C
      PT = 1
C
      DO 90  I = M + 1, N - 1
         CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L )
         PT  = PT  + L
         PDW = PDW + L
   90 CONTINUE
C
      IF ( COMPQ ) THEN
         PDQ = PNR + ( N - 1 )*L*( RRNK + K )
         PNQ = PDQ + MK*MAX( 0, K-RRDF )
         PDW = PNQ + MK*( RRNK + K )
         CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK )
         IF ( M.GT.1 )
     $      CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1),
     $                   LDQ )
         CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ )
         IF ( RRDF.GT.0 )
     $      CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1),
     $                   LDQ )
         CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO,
     $                DWORK(PDQ), MK )
         CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE,
     $                DWORK(PDQ+RRDF), MK )
         CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK )
      ELSE
         PDW = PNR + ( N - 1 )*L*( RRNK + K )
      END IF
      PPR  = 1
      RNK  = RRNK
      RDEF = RRDF
      LEN  = N*L
      GAP  = N*L - MIN( N*L, MK )
C
C     KK is the number of columns in the leading part of the
C     generator. After sufficiently many rank drops or if
C     M*K < N*L it may be less than L.
C
      KK = MIN( L+K-RDEF, L )
      KK = MIN( KK, MK-L )
C
C     Generator reduction process.
C
      DO 190  I = L + 1, MIN( MK, N*L ), L
         IF ( I+L.LE.MIN( MK, N*L ) ) THEN
            LAST = .FALSE.
         ELSE
            LAST = .TRUE.
         END IF
         PP  = KK  + MAX( K - RDEF, 0 )
         LEN = LEN - L
         CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1),
     $                 LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L,
     $                 RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L),
     $                 LDWORK-PDW-5*L+1, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The current generator is indefinite.
C
            INFO = 1
            RETURN
         END IF
C
C        Apply pivoting to other columns of R.
C
         PDP = PDW + 6*L - I
C
         DO 100  J = I, I + KK - 1
            JPVT(J) = JPVT(J) + I - 1
            DWORK(PDP+JPVT(J)) = DBLE(J)
  100    CONTINUE
C
         DO 120  J = I, I + KK - 1
            TEMP = DBLE(J)
            JJ = J-1
C
  110       CONTINUE
            JJ = JJ + 1
            IF ( DWORK(PDP+JJ).NE.TEMP )  GO TO 110
C
            IF ( JJ.NE.J ) THEN
               DWORK(PDP+JJ) = DWORK(PDP+J)
               CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR )
            END IF
  120    CONTINUE
C
         DO 130  J = I + KK, I + L - 1
            JPVT(J) = J
  130    CONTINUE
C
C        Apply reduction to other rows of R.
C
         IF ( LEN.GT.KK ) THEN
            CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP,
     $                   L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR,
     $                   DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L,
     $                   R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L,
     $                   DWORK(PNR+KK), (N-1)*L, DWORK(PDW),
     $                   DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR )
         END IF
C
C        Apply reduction to Q.
C
         IF ( COMPQ ) THEN
            CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP,
     $                   L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR,
     $                   DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L,
     $                   Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ),
     $                   MK, DWORK(PDW), DWORK(PDW+5*L),
     $                   LDWORK-PDW-5*L+1, IERR )
         END IF
C
C        Inspection of the rank deficient columns:
C        Look for small diagonal entries.
C
         NZC = 0
C
         DO 140  J = KK, RRNK + 1, -1
            IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 )  NZC = NZC + 1
  140    CONTINUE
C
C        The last NZC columns of the generator cannot be removed.
C        Now, decide whether for the other rank deficient columns
C        it is safe to remove.
C
         PT = PNR
C
         DO 150  J = RRNK + 1, KK - NZC
            TEMP = R(I+J-1,RNK+J)
            CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 )
            CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1,
     $                  R(I+J,RNK+J), 1 )
            IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 )
     $          .GT.LTOL2*ABS( TEMP ) ) THEN
C
C              Unlucky case:
C              It is neither advisable to remove the whole column nor
C              possible to remove the diagonal entries by Hyperbolic
C              rotations.
C
               INFO = 2
               RETURN
            END IF
            PT = PT + ( N - 1 )*L
  150    CONTINUE
C
C        Annihilate unwanted elements in the factor R.
C
         RRDF = KK - RRNK
         CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR )
         CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2),
     $                LDR )
C
C        Construct the generator for the next step.
C
         IF ( .NOT.LAST ) THEN
C
C           Compute KK for the next step.
C
            KK = MIN( L+K-RDEF-RRDF+NZC, L )
            KK = MIN( KK, MK-I-L+1 )
C
            IF ( KK.LE.0 ) THEN
               RNK = RNK + RRNK
               GO TO 200
            END IF
C
            CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1),
     $                   LDR )
C
C           The columns with small diagonal entries form parts of the
C           new positive generator.
C
            IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN
               CPCOL = MIN( NZC, KK )
C
               DO 160  J = RNK + RRNK + 1, RNK + RRNK + CPCOL
                  CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1,
     $                        R(I+L,J), 1 )
  160          CONTINUE
C
            END IF
C
C           Construct the leading parts of the positive generator.
C
            CPCOL = MIN( RRNK, KK-NZC )
            IF ( CPCOL.GT.0 ) THEN
C
               DO 170  J = I, I + L - 1
                  CALL DCOPY( CPCOL, R(J,RNK+1), LDR,
     $                        R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR )
  170          CONTINUE
C
               IF ( LEN.GT.2*L ) THEN
                  CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR,
     $                         R(I+2*L,RNK+RRNK+NZC+1), LDR )
               END IF
            END IF
            PPR = PPR + L
C
C           Refill the leading parts of the positive generator.
C
            CPCOL = MIN( K-RDEF, KK-RRNK-NZC )
            IF ( CPCOL.GT.0 ) THEN
               CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L,
     $                      R(I+L,RNK+2*RRNK+NZC+1), LDR )
               PPR = PPR + CPCOL*( N - 1 )*L
            END IF
            PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L
C
C           Do the same things for Q.
C
            IF ( COMPQ ) THEN
               IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN
                  CPCOL = MIN( NZC, KK )
C
                  DO 180  J = RNK + RRNK + 1, RNK + RRNK + CPCOL
                     CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 )
  180             CONTINUE
C
               END IF
               CPCOL = MIN( RRNK, KK-NZC )
               IF ( CPCOL.GT.0 ) THEN
                  CALL DLASET( 'All', K, CPCOL, ZERO, ZERO,
     $                         Q(1,RNK+RRNK+NZC+1), LDQ )
                  IF ( M.GT.1 )
     $               CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1),
     $                            LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ )
               END IF
               CPCOL = MIN( K-RDEF, KK-RRNK-NZC )
               IF ( CPCOL.GT.0 ) THEN
                  CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK,
     $                         Q(1,RNK+2*RRNK+NZC+1), LDQ )
                  PDQ = PDQ + CPCOL*MK
               END IF
               PNQ = PNQ + ( RRDF - NZC )*MK
            END IF
         END IF
         RNK  = RNK  + RRNK
         RDEF = RDEF + RRDF - NZC
  190 CONTINUE
C
  200 CONTINUE
      DWORK(1) = DBLE( WRKOPT )
      DWORK(2) = LTOL1
      DWORK(3) = LTOL2
C
C *** Last line of MB02JX ***
      END


      subroutine runCY_00i(k,l,i1,Xtwiddle,Gtwiddle,Shat3,N0)
      implicit none
C---  Expression for Eq. 5.56b
C---  Calculates C00i1
C---  Requires C00l
C---  Small terms of order Xtwiddle(0,k)*Dli1,Xtwiddle(0,0)*Dkli1
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat3(np,z2max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Cv(czzi(i1)+N0,ep)=
     . (-2*Gtwiddle(k,i1)*Cv(czzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat3(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat3(2,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Cv(cii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciii(z3(k,l,i1))+N0,ep))/(2*Gtwiddle(k,l))

      enddo

      return
      end


!-----------------------------------------------------------------------
!     Subroutine:    fieldlines_init_vmec_edgestart
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/15/2016
!     Description:   This subroutine initializes the field line
!                    starting locations from the VMEC edge.
!-----------------------------------------------------------------------
      SUBROUTINE fieldlines_init_vmec_edgestart
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE read_wout_mod, extcur_in => extcur, nextcur_vmec => nextcur
      USE fieldlines_lines, ONLY: nlines
      USE fieldlines_runtime
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: u, v, ik, n_side, mn, n1_side
      REAL(rprec) :: phi_save
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      ! Save the longest line
      phi_save = MAXVAL(phi_end,MASK = r_start > 0)

      ! Reset all values of R_START
      R_START = -1; Z_START=0; PHI_START=0; PHI_END = 0;

      ! Determine grid size
      n_side = floor(sqrt(REAL(MAXLINES)))
      !n_side = 16
      n1_side = n_side-1

      ! Now we just FFT the boundary
      ik = 1;
      DO u = 1, n_side
         DO v = 1, n_side
            R_START(ik) = 0;
            PHI_START(ik) = pi2*(v-1)/n1_side
            DO mn = 1, mnmax
               R_START(ik) = R_START(ik)+rmnc(mn,ns)*cos(pi2*(xm(mn)*(u-1)-xn(mn)*(v-1))/n1_side)
               Z_START(ik) = Z_START(ik)+zmns(mn,ns)*sin(pi2*(xm(mn)*(u-1)-xn(mn)*(v-1))/n1_side)
               IF(lasym) THEN
                  R_START(ik) = R_START(ik)+rmns(mn,ns)*sin(pi2*(xm(mn)*(u-1)-xn(mn)*(v-1))/n1_side)
                  Z_START(ik) = Z_START(ik)+zmnc(mn,ns)*cos(pi2*(xm(mn)*(u-1)-xn(mn)*(v-1))/n1_side)
               END IF
            END DO
            ik = ik + 1
         END DO
      END DO

      ! Populate a space
      !DO u = 1, n_side
      !   DO v = 1, n_side
      !      R_START(ik) = 4.7 + (6.-4.7)*REAL(v-1)/REAL(n_side-1)
      !      Z_START(ik) = -3.2 + (1.2)*REAL(u-1)/REAL(n_side-1)
      !      ik = ik + 1
      !   END DO
      !END DO
      PHI_END = phi_save
      nlines = n_side*n_side

      RETURN
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE fieldlines_init_vmec_edgestart


module integration

  use pde
  use grid
  use global_module

  implicit none

  contains

  ! ========================================================================

  subroutine forward_Euler_step(U, U_new, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(:,:), intent(inout)  :: U, U_new

    real(kind=8), intent(in) :: dt
    integer :: eleID, eqID, intID

    real(kind=8), dimension(Neq) :: F_dot_n, U_sym
    real(kind=8) :: nx, ny, Lint, Aele
    integer      :: neigh

    do eleID = 1, Nele

      Aele = ele_geom(eleID, 1)
      U_new(:,eleID) = U(:,eleID) ! Init

      do intID = 1, 4 ! Only quad element supported

        F_dot_n = 0.0 ! Init

        ! Extract data
        Lint = ele_int_len(eleID,intID)
        nx   = ele_int_nx(eleID,intID)
        ny   = ele_int_ny(eleID,intID)

        neigh = ele_neigh(eleID,intID)

        ! Check what neighbor is it
        if (neigh .gt. 0) then ! +++++++++ INTERNAL CELL

          call compute_fluxes_HLL(U(:,eleID), U(:,neigh), nx, ny, F_dot_n, Aele)

        else if (neigh .eq. -1) then ! ++++++++ INLET BOUNDARY +++++++++++++++++++

          call compute_fluxes_HLL(U(:,eleID), U_inlet, nx, ny, F_dot_n, Aele)

        else if (neigh .eq. -2) then ! ++++++++ OUTLET BOUNDARY +++++++++++++++++++

          call compute_fluxes_HLL(U(:,eleID), U_outlet, nx, ny, F_dot_n, Aele)

        else if (neigh .eq. -3) then ! ++++++++ WALL BOUNDARY ++++++++++++++++++++

          call compute_wall_flux(U(:,eleID), nx, ny, F_dot_n, Aele)

        else if (neigh .eq. -4) then ! ++++++++ SYM BOUNDARY ++++++++++++++++++++

          call compute_sym_state(U(:,eleID), nx, ny, U_sym)
          call compute_fluxes_HLL(U(:,eleID), U_sym, nx, ny, F_dot_n, Aele)

        else
          print*, "ERROR! UNKNOWN BOUNDARY TYPE ", neigh, " for element ", eleID, " Check the mesh or the pre-processing."
          print*, "ABORTING!"
          STOP
        end if

        ! Update solution
        U_new(:,eleID) = U_new(:,eleID) - dt*F_dot_n*Lint/Aele

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U_new(eqID,eleID))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            print*, 'Solution that diverged: ', U_new(:,eleID)
            print*, 'in cell ID = ', eleID
            stop
          end if
        end do

      end do ! End loop on interfaces

    end do ! End loop on elements

    U = U_new ! Save results

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_HLL(U_L, U_R, nx, ny, F_dot_n, A_ele)

    ! Computes HLL numerical fluxes among the cell eleID and the neighbor cell neigh
    ! The element area Aele is also passed, for the sake of computing the CFL number.

    implicit none

    real(kind=8), dimension(:),   intent(in)  :: U_L, U_R
    real(kind=8),                 intent(in)  :: nx, ny, A_ele
    real(kind=8), dimension(Neq), intent(out) :: F_dot_n

    real(kind=8), dimension(Neq) :: F_L, F_R

    ! Wave speeds
    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_max, ws_min

    call compute_flux_ws(U_L, F_L, nx, ny, ws_max_L, ws_min_L)
    call compute_flux_ws(U_R, F_R, nx, ny, ws_max_R, ws_min_R)

    ws_min = MIN(ws_min_L, ws_min_R)
    ws_max = MAX(ws_max_L, ws_max_R)

    ! HLL fluxes
    if (ws_min .ge. 0.0) then
      F_dot_n = F_L
    else if (ws_max .lt. 0.0) then
      F_dot_n = F_R
    else
      F_dot_n = (ws_min*ws_max*(U_R - U_L) + ws_max*F_L - ws_min*F_R)/(ws_max - ws_min);
    end if

    ! Update global maximum wave speed (used for setting the time step)
    ws_max = abs(ws_max)
    ws_over_sqrtA_maxabs = MAX(ws_over_sqrtA_maxabs, ws_max/sqrt(A_ele))

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_Rusanov(U_L, U_R, nx, ny, F_dot_n, A_ele)

    ! Computes Rusanov numerical fluxes among the cell eleID and the neighbor cell neigh
    ! The element area A_ele is also passed, for the sake of computing the Courant number

    implicit none

    real(kind=8), dimension(:),   intent(in)  :: U_L, U_R
    real(kind=8),                 intent(in)  :: nx, ny, A_ele
    real(kind=8), dimension(Neq), intent(out) :: F_dot_n

    real(kind=8), dimension(Neq) :: F_L, F_R

    ! Wave speeds
    real(kind=8) :: ws_min_L, ws_max_L, ws_min_R, ws_max_R, ws_max

    call compute_flux_ws(U_L, F_L, nx, ny, ws_max_L, ws_min_L)
    call compute_flux_ws(U_R, F_R, nx, ny, ws_max_R, ws_min_R)

    ws_max  = MAX(ABS(ws_max_L), ABS(ws_min_L), ABS(ws_max_R), ABS(ws_min_R))

    F_dot_n = 0.5*(F_R + F_L) - ws_max/2.0*(U_R-U_L) ! Rusanov flux

    ! Update global maximum wave speed (used for setting the time step)
    ws_over_sqrtA_maxabs = MAX(ws_over_sqrtA_maxabs, ws_max/sqrt(A_ele))

  end subroutine

end module


PROGRAM test_TP
!
      USE def_constants
      USE def_variables
      USE non_linear_solvers
      USE properties
      USE grid_functions
      USE Grid
      USE Interp_table
!      USE derivees
!      USE interp_functions
!      USE saturation
      IMPLICIT NONE
!======================================================================
!
!       Test points in two-phase region
!
!======================================================================
      REAL(pr) :: p, T, c, a, res, u_in, v_in,T_ref,v_l,v_v,&
&                 resnorm,in_2, vl_guess,vv_guess,e_v,e_l,p_guess,x_out,&
&                 delta
      INTEGER :: Niter, exitflag,i,j,NN
      REAL(pr), DIMENSION(500) :: T_tab,p_tab
      REAL(pr), DIMENSION(500) :: x_tab
      REAL(pr) :: Perr,Terr,xerr
!
      NN = 500
      delta = (T_cr-0.01_pr - (T_tri+0.01_pr))/ (NN)
      T_tab = T_tri+0.1_pr + (/(i*delta,i=0,NN-1)/)
      delta = 1.0_pr / (NN)
      x_tab = 0.0001_pr + (/(i*delta,i=0,NN-1)/)

!print*,x_tab
!
        CALL MAKE_GRID()
!STOP
      p=0_pr
      T=0_pr
      c=0_pr
      a=0_pr
      res=0_pr
!print*, "T_tab", T_tab
      vl_guess = 1_pr/rho_tri_L + 1e-4
      vv_guess = 1_pr/rho_tri_R - 1e-4
      T_ref = 260_pr

OPEN (UNIT = 22,             FILE = 'TP2_T-x-vV-p-u-v.txt', &
&   FORM = 'formatted',     ACTION = 'write',   &
&   STATUS = 'replace')
!
OPEN (UNIT = 42,             FILE = 'TP2_error-P-T-x.txt', &
&   FORM = 'formatted',     ACTION = 'write',   &
&   STATUS = 'replace')

        DO i=1,NN
!print*, i, T_tab(i)
        CALL New_Rap2D(1, v_l,v_v, &
     &           resnorm, Niter, exitflag, T_tab(i), in_2, vl_guess, vv_guess)
!
       IF (resnorm > 1e-10) THEN
                print*, "res", resnorm, "iter", Niter
                STOP
        ENDIF
!
        vl_guess = v_l
        vv_guess = v_v
        CALL inter_energy(T_tab(i),v_v,e_v)
        CALL inter_energy(T_tab(i),v_l,e_l)
        CALL pressure(T_tab(i),v_v,p_tab(i))!
!print*, T_tab(i),p_tab(i)
!print*,i, v_l, v_v
!print*,i, e_v, e_l
!!    print*,"error v", (v_l-1_pr/998.89_pr)/(1_pr/998.89_pr),&
!!&           (v_v-1_pr/64.417_pr)/(1_pr/64.417_pr)
            p_guess = p_tab(i)
          DO j=1,NN
 ! print*,i,j
            v_in = x_tab(j)*v_v + (1_pr - x_tab(j))* v_l
            u_in = x_tab(j)*e_v + (1_pr - x_tab(j))* e_l
!   print*,x_tab(j), T_tab(i)!,v_v,v_l
!print*, i,j,"v_in",v_in,"u_in",u_in, p_guess

        CALL CO2BLLT_EQUI(p, T, c, x_out, a, res, u_in,v_in,p_guess)
!print*,i,j, 'output',p,T,c,x_out
        Perr = abs(p-p_tab(i))/p_tab(i)
        Terr = abs(T-T_tab(i))/T_tab(i)
        xerr = abs(x_out-x_tab(j))/x_tab(j)
!        xerr = 0.0
        p_guess = p

WRITE(22,*) T_tab(i), x_tab(j),v_v ,p,u_in,v_in,c,a
WRITE(42,*) Perr, Terr,xerr,u_in,v_in, Terr*T_tab(i)
    IF ( (Perr> 0.1_pr) .OR. (Terr >0.1) ) THEN
       print*, i,j, 'v', v_in, 'u', u_in
       print*, "error for T=", abs(T-T_tab(i))/T_tab(i), 'T_tb', T,'T_ref',T_tab(i)
       print*, "error for p=", p,p_tab(i),abs(p-p_tab(i))/p_tab(i)
       print*," "
!       print*, "error for x=", x_tab(j), x_out,abs(x_tab(j)-x_out)/x_tab(j)
    ENDIF
          ENDDO
         ENDDO
!!
 CLOSE(UNIT = 22)
 CLOSE(UNIT = 42)
print*," ==========>test_TP FINISH<=============="
END PROGRAM test_TP


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief calculates viscosity of aqueous NaCl solutions
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return  visc
!> @details
!> Source:\n
!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
!> GEOPHYSICS, 57(11), 1396–1408 (1992).
!> http://dx.doi.org/10.1190/1.1443207 \n\n
!>\n
!>   Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n
!>\n
      double precision function visf(i,j,k,ismpl)
        use arrays, only: pres, temp, tsal
        use mod_flow, only: pa_conv1

        implicit none

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Temperature (degC)
        double precision :: t

        ! Pressure (MPa)
        double precision :: p

        ! Salinity (mol/L)
        double precision :: s

        ! Mass fraction [-]
        double precision :: sr

        ! Pure water density (kg/m3)
        double precision :: rw
        double precision, external :: rhow

        ! Pure water viscosity [Pa s]
        double precision, external :: visw

        ! Molar mass of NaCl [g/mol]
        ! double precision, parameter :: mmnacl = 58.44277d0
        double precision, parameter :: mmnacl = 58.44d0

        ! Viscosity [cP]
        double precision :: visf_cp

        ! Pressure [MPa]
        p = pres(i,j,k,ismpl)*pa_conv1

        ! Temperature [degC]
        t = temp(i,j,k,ismpl)

        ! Salinity [mol/L]
        s = tsal(i,j,k,ismpl)

        if (s <= 0.D0) then

          visf = visw(p,t)

        else

          ! Pure water density [kg/m3]
          rw = rhow(p,t)

          ! mol/L (Molarity) > [g/L] = [kg/m3; ]g/g (mass fraction)
          sr = s*mmnacl/(rw+s*mmnacl)

          ! Viscosity formula after Batzle & Wang [cP]
          visf_cp = 0.1d0 + 0.333d0 * sr  &
              + (1.65d0 + 91.9d0 * sr**3) * &
              exp(-(0.42d0 * (sr**(0.8d0) - 0.17d0)**2 + 0.045d0) * t**(0.8d0))

          ! Conversion of viscosity from [cP] to [Pa s]
          visf = visf_cp * 1.0d-3

        end if

        return

      end function visf


c $Id: fccf.f,v 1.1 2002/12/03 10:59:19 straten Exp $
c $Log: fccf.f,v $
c Revision 1.1  2002/12/03 10:59:19  straten
c fccf.f from tas/archive
c
c Revision 1.1.1.1  1998/08/03  06:39:55  mbritton
c start
c
c Revision 1.1  1994/11/25  03:17:24  jsandhu
c Initial revision
c
c Revision 1.1  1994/11/25  03:17:24  jsandhu
c Initial revision
c

* fccf.f,v 1.1 93/10/29 22:51:12 will
C @(#)fccf.f	1.1 9/7/90
	subroutine fccf(amp,pha,shift)

C  Input: Fourier-domain CCF of two profiles: amp = A1*A2, pha = phi1 - phi2.
C  Output: Using 16 harmonics of amp and pha array, finds maximum of CCF
C  at 64 lags over the pulsar period, and returns value of shift in radians.
*	MODIFICATIONS:
*		real*4 -> real.

	parameter (nprof=64)
	parameter (MAXSAM=8192,twopi=6.2831853)
	real amp(MAXSAM/2),pha(MAXSAM/2)
	complex ccf(0:63)

	nh=nprof/2
	ccf(0)=(0.,0.)
	do 10 i=1,nh/2
	 ccf(i)=cmplx(amp(i)*cos(pha(i)),amp(i)*sin(pha(i)))
10	 ccf(nprof-i)=conjg(ccf(i))
	do 20 i=nh/2+1,nh
	 ccf(i)=(0.,0.)
20	 ccf(nprof-i)=(0.,0.)
	call ffft(ccf,nprof,-1,0)
	cmax=-1.e30
	do 30 i=0,63
	 rc=real(ccf(i))
	 if (rc.gt.cmax) then
	   cmax=rc
	   imax=i
	 end if
30	continue

	fb=cmax
	ia=imax-1
	if(ia.eq.-1) ia=nprof-1
	fa=real(ccf(ia))
	ic=imax+1
	if(ic.eq.nprof) ic=0
	fc=real(ccf(ic))
	if ((2*fb-fc-fa).ne.0) then
	  shift=imax+0.5*(fa-fc)/(2*fb-fc-fa)
	else
	  shift=imax
	end if
	if(shift.gt.nh) shift=shift-nprof
	shift=shift*twopi/nprof

	return
	end