!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
module type_GeneralizedCyclicReductionUtility

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip, & ! Integer precision
        MACHINE_EPSILON ! Machine epsilon

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: GeneralizedCyclicReductionUtility
    public :: ppsgf
    public :: ppspf
    public :: psgf
    public :: comf_interface

    ! Parameters confined to the module
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    integer(ip), parameter :: SIZE_OF_WORKSPACE_INDICES = 6

    type, public :: GeneralizedCyclicReductionUtility
        ! Type components
        integer(ip) :: indices(SIZE_OF_WORKSPACE_INDICES)
        integer(ip) :: nl, npp, k, nm, ncmplx, ik
        real(wp)    :: cnv
    contains
        ! Public type-bound procedures
        procedure,         public :: blktrii
        procedure, nopass, public :: check_input_arguments
        procedure, nopass, public :: ppsgf
        procedure, nopass, public :: ppspf
        procedure, nopass, public :: psgf
        ! Private type-bound procedures
        procedure, private :: blktri_lower_routine
        procedure, private :: bsrh
        procedure, private :: compute_roots_of_b_polynomials
        procedure, private :: compute_eigen_values
        procedure, private :: tevls
        procedure, private :: compute_index_a_coeff
        procedure, private :: compute_index_b_coeff
        procedure, private :: compute_index_c_coeff
    end type GeneralizedCyclicReductionUtility

    ! Declare interface
    interface
        function comf_interface(x, iz, c, a, bh) &
            result (return_value)
            import :: ip, wp

            ! Dummy arguments
            integer(ip), intent(in) :: iz
            real(wp),    intent(in) :: x
            real(wp),    intent(in) :: c(*)
            real(wp),    intent(in) :: a(*)
            real(wp),    intent(in) :: bh(*)
            real(wp)                :: return_value
        end function comf_interface
    end interface

contains

    pure function ppsgf(x, iz, c, a, bh) &
        result (return_value)

        ! Dummy arguments
        integer(ip),    intent(in)    :: iz
        real(wp),       intent(in)    :: x
        real(wp),       intent(in)    :: c(*)
        real(wp),       intent(in)    :: a(*)
        real(wp),       intent(in)    :: bh(*)
        real(wp)                      :: return_value

        return_value = sum(ONE/(x - bh(1:iz))**2)

    end function ppsgf

    pure function ppspf(x, iz, c, a, bh) &
        result (return_value)

        ! Dummy arguments
        integer(ip),    intent(in)    :: iz
        real(wp),       intent(in)    :: x
        real(wp),       intent(in)    :: c(*)
        real(wp),       intent(in)    :: a(*)
        real(wp),       intent(in)    :: bh(*)
        real(wp)                      :: return_value

        return_value = sum(ONE/(x - bh(1:iz)))

    end function ppspf

    pure function psgf(x, iz, c, a, bh) &
        result (return_value)

        ! Dummy arguments
        integer(ip),    intent(in)    :: iz
        real(wp),       intent(in)    :: x
        real(wp),       intent(in)    :: c(*)
        real(wp),       intent(in)    :: a(*)
        real(wp),       intent(in)    :: bh(*)
        real(wp)                      :: return_value

        ! Local variables
        integer(ip) :: j
        real(wp)    :: fsg, hsg, dd

        fsg = ONE
        hsg = ONE

        do j = 1, iz
            dd = ONE/(x - bh(j))
            fsg = fsg * a(j) * dd
            hsg = hsg * c(j) * dd
        end do

        select case (mod(iz,2))
            case (0)
                return_value = ONE - fsg - hsg
            case default
                return_value = ONE + fsg + hsg
        end select

    end function psgf

    pure subroutine check_input_arguments(n, m, idimy, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: n, m, idimy
        integer(ip), intent(out) :: ierror

        if (m < 5) then
            ierror = 1
        else if (n < 3) then
            ierror = 2
        else if (idimy < m) then
            ierror = 3
        else
            ierror = 0
        end if

    end subroutine check_input_arguments

    subroutine blktrii(self, iflg, np, n, an, bn, cn, mp, m, am, bm, cm, &
        idimy, y, ierror, w, wc)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(in)    :: iflg
        integer(ip),      intent(in)    :: np
        integer(ip),      intent(in)    :: n
        integer(ip),      intent(in)    :: mp
        integer(ip),      intent(in)    :: m
        integer(ip),      intent(in)    :: idimy
        integer(ip),      intent(out)   :: ierror
        real(wp),         intent(in)    :: an(:)
        real(wp),         intent(in)    :: bn(:)
        real(wp),         intent(in)    :: cn(:)
        real(wp),         intent(in)    :: am(:)
        real(wp),         intent(in)    :: bm(:)
        real(wp),         intent(in)    :: cm(:)
        real(wp),         intent(inout) :: y(:,:)
        real(wp),         intent(inout) :: w(:)
        complex(wp),      intent(inout) :: wc(:)

        ! Local variables
        integer(ip) :: nh, iwah, iwbh

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ik => self%ik &
            )

            ! test m and n for the proper form
            nm = n

            ! Check again for solvers which call blktrii directly
            call check_input_arguments(nm, m, idimy, ierror)

            ! Check error flag
            if (ierror /= 0) return

            associate( &
                iw1 => self%indices(1), &
                iw2 => self%indices(2), &
                iw3 => self%indices(3), &
                iww => self%indices(4), &
                iwu => self%indices(5), &
                iwd => self%indices(6), &
                nl => self%nl &
                )

                select case (iflg)
                    case (0)
                        nh = n
                        npp = np
                        if (npp /= 0)  nh = nh + 1
                        ik = 4
                        k = 2

                        do
                            if (nh <= ik) exit
                            ik = 2*ik
                            k = k + 1
                        end do

                        nl = ik
                        ik = 2*ik
                        nl = nl - 1
                        iwah = (k - 2)*ik + k + 5

                        if (npp == 0) then
                            iwbh = iwah + 2*nm
                            iw1 = iwbh
                            nm = n - 1
                        else
                            iw1 = iwah
                            iwbh = iw1 + nm
                        end if
                        !
                        ! Set workspace indices
                        !
                        iw2 = iw1 + m
                        iw3 = iw2 + m
                        iwd = iw3 + m
                        iww = iwd + m
                        iwu = iww + m

                        call self%compute_roots_of_b_polynomials(nl, ierror, an, bn, cn, w, wc, w(iwah:), w(iwbh:))

                    case default

                        ! *** Important to reset nm for np = 0
                        if (npp == 0) nm = n - 1

                        select case (mp)
                            case (0)
                                call self%blktri_lower_routine(an, cn, m, am, bm, cm, y, w, wc, &
                                    w(iw1:), w(iw2:), w(iw3:), w(iwd:), w(iww:), w(iwu:), wc(iw1:), &
                                    wc(iw2:), wc(iw3:), prodp, cprodp)
                            case default
                                call self%blktri_lower_routine(an, cn, m, am, bm, cm, y, w, wc, &
                                    w(iw1:), w(iw2:), w(iw3:), w(iwd:), w(iww:), w(iwu:), wc(iw1:), &
                                    wc(iw2:), wc(iw3:), prod, cprod)
                        end select
                end select

            end associate

        end associate common_variables

    end subroutine blktrii

    ! Purpose:
    !
    ! Solves the linear system
    !
    ! b  contains the roots of all the b polynomials
    ! w1, w2, w3, wd, ww, wu  are all working arrays
    ! prdct  is either prodp or prod depending on whether the boundary
    ! conditions in the m direction are periodic or not
    ! cprdct is either cprodp or cprod which are the complex versions
    ! of prodp and prod. these are called in the event that some
    ! of the roots of the b sub p polynomial are complex
    !
    subroutine blktri_lower_routine(self, an, cn, m, am, bm, cm, y, b, bc, &
        w1, w2, w3, wd, ww, wu, cw1, cw2, cw3, prdct, cprdct)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip), intent(in)     :: m
        real(wp),    intent(in)     :: an(:)
        real(wp),    intent(in)     :: cn(:)
        real(wp),    intent(in)     :: am(:)
        real(wp),    intent(in)     :: bm(:)
        real(wp),    intent(in)     :: cm(:)
        real(wp),    intent(inout)  :: y(:,:)
        real(wp),    intent(in)     :: b(*)
        real(wp),    intent(inout)  :: w1(*)
        real(wp),    intent(inout)  :: w2(*)
        real(wp),    intent(inout)  :: w3(*)
        real(wp),    intent(in)     :: wd(*)
        real(wp),    intent(in)     :: ww(*)
        real(wp),    intent(in)     :: wu(*)
        complex(wp), intent(in)     :: bc(*)
        complex(wp), intent(in)     :: cw1(*)
        complex(wp), intent(in)     :: cw2(*)
        complex(wp), intent(in)     :: cw3(*)
        external :: prdct, cprdct

        ! Local variables
        integer(ip) :: kdo, l, ir, i2, i1, i3, i4, irm1, im2, nm2, im3, nm3
        integer(ip) :: im1, nm1, i0, iif, i, ipi1, ipi2, ipi3, idxc, nc, idxa, na, ip2
        integer(ip) :: np2, ip1, np1, ip3, np3, iz, nz, izr, ll, ifd, iip, np
        integer(ip) :: imi1, imi2
        real(wp)    :: dummy_variable

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ncmplx=> self%ncmplx, &
            ik => self%ik, &
            cnv => self%cnv &
            )
            ! begin reduction phase
            kdo = k - 1
            do l = 1, kdo
                ir = l - 1
                i2 = 2**ir
                i1 = i2/2
                i3 = i2 + i1
                i4 = i2 + i2
                irm1 = ir - 1
                call self%compute_index_b_coeff(i2, ir, im2, nm2)
                call self%compute_index_b_coeff(i1, irm1, im3, nm3)
                call self%compute_index_b_coeff(i3, irm1, im1, nm1)

                i0 = 0

                call prdct(nm2, b(im2), nm3, b(im3), nm1, b(im1), i0, dummy_variable, &
                    y(1, i2), w3, m, am, bm, cm, wd, ww, wu)

                iif = 2**k

                do i = i4, iif, i4

                    if (i > nm) cycle

                    ipi1 = i + i1
                    ipi2 = i + i2
                    ipi3 = i + i3

                    call self%compute_index_c_coeff(i, ir, idxc, nc)

                    if (i >= iif) cycle

                    call self%compute_index_a_coeff(i, ir, idxa, na)
                    call self%compute_index_b_coeff(i - i1, irm1, im1, nm1)
                    call self%compute_index_b_coeff(ipi2, ir, ip2, np2)
                    call self%compute_index_b_coeff(ipi1, irm1, ip1, np1)
                    call self%compute_index_b_coeff(ipi3, irm1, ip3, np3)
                    call prdct(nm1, b(im1), 0, dummy_variable, 0, dummy_variable, na, an(idxa), w3, &
                        w1, m, am, bm, cm, wd, ww, wu)

                    if (ipi2 > nm) then
                        w3(:m) = ZERO
                        w2(:m) = ZERO
                    else
                        call prdct(np2, b(ip2), np1, b(ip1), np3, b(ip3), 0, dummy_variable, &
                            y(1, ipi2), w3, m, am, bm, cm, wd, ww, wu)
                        call prdct(np1, b(ip1), 0, dummy_variable, 0, dummy_variable, nc, cn(idxc), w3, &
                            w2, m, am, bm, cm, wd, ww, wu)
                    end if
                    y(:m, i) = w1(:m) + w2(:m) + y(:m, i)
                end do
            end do

            if (npp == 0) then
                iif = 2**k
                i = iif/2
                i1 = i/2

                call self%compute_index_b_coeff(i - i1, k - 2, im1, nm1)
                call self%compute_index_b_coeff(i + i1, k - 2, ip1, np1)
                call self%compute_index_b_coeff(i, k - 1, iz, nz)
                call prdct(nz, b(iz), nm1, b(im1), np1, b(ip1), 0, dummy_variable, &
                    y(1, i), w1, m, am, bm, cm, wd, ww, wu)

                izr = i
                w2(:m) = w1(:m)

                do ll = 2, k
                    l = k - ll + 1
                    ir = l - 1
                    i2 = 2**ir
                    i1 = i2/2
                    i = i2

                    call self%compute_index_c_coeff(i, ir, idxc, nc)
                    call self%compute_index_b_coeff(i, ir, iz, nz)
                    call self%compute_index_b_coeff(i - i1, ir - 1, im1, nm1)
                    call self%compute_index_b_coeff(i + i1, ir - 1, ip1, np1)
                    call prdct(np1, b(ip1), 0, dummy_variable, 0, dummy_variable, nc, cn(idxc), w1, &
                        w1, m, am, bm, cm, wd, ww, wu)

                    w1(:m) = y(:m, i) + w1(:m)

                    call prdct(nz, b(iz), nm1, b(im1), np1, b(ip1), 0, &
                        dummy_variable, w1, w1, m, am, bm, cm, wd, ww, wu)
                end do

                outer_loop: do ll = 2, k
                    l = k - ll + 1
                    ir = l - 1
                    i2 = 2**ir
                    i1 = i2/2
                    i4 = i2 + i2
                    ifd = iif - i2
                    inner_loop: do i = i2, ifd, i4

                        if (i - i2 - izr /= 0) cycle inner_loop

                        if (i > nm) cycle outer_loop

                        call self%compute_index_a_coeff(i, ir, idxa, na)
                        call self%compute_index_b_coeff(i, ir, iz, nz)
                        call self%compute_index_b_coeff(i - i1, ir - 1, im1, nm1)
                        call self%compute_index_b_coeff(i + i1, ir - 1, ip1, np1)
                        call prdct(nm1, b(im1), 0, dummy_variable, 0, dummy_variable, na, an(idxa), &
                            w2, w2, m, am, bm, cm, wd, ww, wu)

                        w2(:m) = y(:m, i) + w2(:m)

                        call prdct(nz, b(iz), nm1, b(im1), np1, b(ip1), 0, dummy_variable, &
                            w2, w2, m, am, bm, cm, wd, ww, wu)

                        izr = i

                        if (i == nm) exit outer_loop

                    end do inner_loop
                end do outer_loop

                y(:m, nm+1) = y(:m, nm+1) - cn(nm+1)*w1(:m) - an(nm+1)*w2(:m)

                call self%compute_index_b_coeff(iif/2, k - 1, im1, nm1)
                call self%compute_index_b_coeff(iif, k - 1, iip, np)

                if (ncmplx /= 0) then
                    call cprdct(nm + 1, bc(iip), nm1, b(im1), 0, dummy_variable, 0, dummy_variable, &
                        y(1, nm+1), y(1, nm+1), m, am, bm, cm, cw1, cw2, cw3)
                else
                    call prdct(nm + 1, b(iip), nm1, b(im1), 0, dummy_variable, 0, dummy_variable, &
                        y(1, nm+1), y(1, nm+1), m, am, bm, cm, wd, ww, wu)
                end if

                w1(:m) = an(1)*y(:m, nm+1)
                w2(:m) = cn(nm)*y(:m, nm+1)
                y(:m, 1) = y(:m, 1) - w1(:m)
                y(:m, nm) = y(:m, nm) - w2(:m)

                do l = 1, kdo
                    ir = l - 1
                    i2 = 2**ir
                    i4 = i2 + i2
                    i1 = i2/2
                    i = i4

                    call self%compute_index_a_coeff(i, ir, idxa, na)
                    call self%compute_index_b_coeff(i - i2, ir, im2, nm2)
                    call self%compute_index_b_coeff(i - i2 - i1, ir - 1, im3, nm3)
                    call self%compute_index_b_coeff(i - i1, ir - 1, im1, nm1)
                    call prdct(nm2, b(im2), nm3, b(im3), nm1, b(im1), 0, dummy_variable, &
                        w1, w1, m, am, bm, cm, wd, ww, wu)
                    call prdct(nm1, b(im1), 0, dummy_variable, 0, dummy_variable, na, an(idxa), w1, &
                        w1, m, am, bm, cm, wd, ww, wu)

                    y(:m, i) = y(:m, i) - w1(:m)
                end do

                izr = nm

                loop_131: do l = 1, kdo
                    ir = l - 1
                    i2 = 2**ir
                    i1 = i2/2
                    i3 = i2 + i1
                    i4 = i2 + i2
                    irm1 = ir - 1
                    loop_132: do i = i4, iif, i4
                        ipi1 = i + i1
                        ipi2 = i + i2
                        ipi3 = i + i3

                        if (ipi2 /= izr) then

                            if (i /= izr) cycle loop_132

                            cycle loop_131

                        end if

                        call self%compute_index_c_coeff(i, ir, idxc, nc)
                        call self%compute_index_b_coeff(ipi2, ir, ip2, np2)
                        call self%compute_index_b_coeff(ipi1, irm1, ip1, np1)
                        call self%compute_index_b_coeff(ipi3, irm1, ip3, np3)

                        call prdct(np2, b(ip2), np1, b(ip1), np3, b(ip3), 0, &
                            dummy_variable, w2, w2, m, am, bm, cm, wd, ww, wu)

                        call prdct(np1, b(ip1), 0, dummy_variable, 0, dummy_variable, nc, cn(idxc), &
                            w2, w2, m, am, bm, cm, wd, ww, wu)

                        y(:m, i) = y(:m, i) - w2(:m)
                        izr = i

                        cycle loop_131
                    end do loop_132
                end do loop_131
            end if
            !
            ! begin back substitution phase
            !
            do ll = 1, k
                l = k - ll + 1
                ir = l - 1
                irm1 = ir - 1
                i2 = 2**ir
                i1 = i2/2
                i4 = i2 + i2
                ifd = iif - i2
                inner_back_sub: do i = i2, ifd, i4

                    if (i > nm) cycle inner_back_sub

                    imi1 = i - i1
                    imi2 = i - i2
                    ipi1 = i + i1
                    ipi2 = i + i2

                    call self%compute_index_a_coeff(i, ir, idxa, na)
                    call self%compute_index_c_coeff(i, ir, idxc, nc)
                    call self%compute_index_b_coeff(i, ir, iz, nz)
                    call self%compute_index_b_coeff(imi1, irm1, im1, nm1)
                    call self%compute_index_b_coeff(ipi1, irm1, ip1, np1)

                    if (i <= i2) then
                        w1(:m) = ZERO
                    else
                        call prdct(nm1, b(im1), 0, dummy_variable, 0, dummy_variable, na, an(idxa), &
                            y(1,imi2), w1, m, am, bm, cm, wd, ww, wu)
                    end if

                    if (ipi2 > nm) then
                        w2(:m) = ZERO
                    else
                        call prdct(np1, b(ip1), 0, dummy_variable, 0, dummy_variable, nc, cn(idxc), &
                            y(1,ipi2), w2, m, am, bm, cm, wd, ww, wu)
                    end if

                    w1(:m) = y(:m, i) + w1(:m) + w2(:m)

                    call prdct(nz, b(iz), nm1, b(im1), np1, b(ip1), 0, dummy_variable, &
                        w1, y(1, i), m, am, bm, cm, wd, ww, wu)
                end do inner_back_sub
            end do
        end associate common_variables

    end subroutine blktri_lower_routine

    function bsrh(self, xll, xrr, iz, c, a, bh, sgn, f) &
        result (return_value)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        real(wp),         intent(in)    :: xll
        real(wp),         intent(in)    :: xrr
        integer(ip),      intent(in)    :: iz
        real(wp),         intent(in)    :: c(:)
        real(wp),         intent(in)    :: a(:)
        real(wp),         intent(in)    :: bh(:)
        real(wp),         intent(in)    :: sgn
        procedure(comf_interface)       :: f
        real(wp)                        :: return_value

        ! Local variables
        real(wp) :: r1, xl, xr, dx, x

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ncmplx=> self%ncmplx, &
            ik => self%ik, &
            cnv => self%cnv &
            )

            xl = xll
            xr = xrr
            dx = abs(xr - xl)/2
            x = (xl + xr)/2
            r1 = sgn * f(x, iz, c, a, bh)

            if (r1 >= ZERO) then
                if (r1 == ZERO) then
                    return_value = (xl + xr)/2
                    return
                end if
                xr = x
            else
                xl = x
            end if

            dx = dx/2

            do
                if (dx - cnv > ZERO) exit
                x = (xl + xr)/2
                r1 = sgn * f(x, iz, c, a, bh)
                if (r1 >= ZERO) then
                    if (r1 == ZERO) then
                        return_value = (xl + xr)/2
                        return
                    end if
                    xr = x
                else
                    xl = x
                end if
                dx = dx/2
            end do

            return_value = (xl + xr)/2
        end associate common_variables

    end function bsrh

    ! Purpose:
    !
    ! Computes the roots of the b polynomials using subroutine
    ! tevls which is a modification the eispack program tqlrat.
    ! ierror is set to 4 if either tevls fails or if a(j+1)*c(j) is
    ! less than zero for some j.  ah, bh are temporary work arrays.
    !
    subroutine compute_roots_of_b_polynomials(self, n, ierror, an, bn, cn, b, bc, ah, bh)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(in)    :: n
        integer(ip),      intent(out)   :: ierror
        real(wp),         intent(in)    :: an(:)
        real(wp),         intent(in)    :: bn(:)
        real(wp),         intent(in)    :: cn(:)
        real(wp),         intent(inout) :: b(:)
        real(wp),         intent(inout) :: ah(:)
        real(wp),         intent(inout) :: bh(:)
        complex(wp),      intent(inout) :: bc(:)

        ! Local variables

        integer(ip)  :: j, iif, kdo, l, ir, i2, i4, ipl, ifd, i, ib, nb, js, jf
        integer(ip)  :: ls, lh, nmp, l1, l2, j2, j1, n2m2
        real(wp)     :: bnorm, arg, d1, d2, d3

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ncmplx=> self%ncmplx, &
            ik => self%ik, &
            cnv => self%cnv &
            )

            bnorm = abs(bn(1))

            do j = 2, nm
                bnorm = max(bnorm, abs(bn(j)))
                arg = an(j)*cn(j-1)

                if (arg < ZERO) then
                    ierror = 5
                    return
                end if

                b(j) = sign(sqrt(arg), an(j))
            end do

            cnv = MACHINE_EPSILON*bnorm
            iif = 2**k
            kdo = k - 1

            outer_loop: do l = 1, kdo
                ir = l - 1
                i2 = 2**ir
                i4 = i2 + i2
                ipl = i4 - 1
                ifd = iif - i4
                do i = i4, ifd, i4
                    call self%compute_index_b_coeff(i, l, ib, nb)

                    if (nb <= 0) cycle outer_loop

                    js = i - ipl
                    jf = js + nb - 1
                    ls = 0
                    bh(:jf-js+1) = bn(js:jf)
                    ah(:jf-js+1) = b(js:jf)

                    associate( order => nb )
                        call self%tevls(bh(1:order), ah(1:order), ierror)
                    end associate

                    if (ierror /= 0) then
                        ierror = 4
                        return
                    end if

                    lh = ib - 1
                    if (nb > 0) then
                        b(lh+1:nb+lh) = -bh(:nb)
                        lh = nb + lh
                    end if
                end do
            end do outer_loop

            b(:nm) = -bn(:nm)

            if (npp == 0) then
                nmp = nm + 1
                nb = nm + nmp
                do j = 1, nb
                    l1 = mod(j - 1, nmp) + 1
                    l2 = mod(j + nm - 1, nmp) + 1
                    arg = an(l1)*cn(l2)

                    if (arg < ZERO) then
                        ierror = 5
                        return
                    end if

                    bh(j) = sign(sqrt(arg), (-an(l1)))
                    ah(j) = -bn(l1)
                end do

                associate( order => nb )
                    call self%tevls(ah(1:order), bh(1:order), ierror)
                end associate

                if (ierror /= 0) then
                    ierror = 4
                    return
                end if

                call self%compute_index_b_coeff(iif, k - 1, j2, lh)
                call self%compute_index_b_coeff(iif/2, k - 1, j1, lh)

                j2 = j2 + 1
                lh = j2
                n2m2 = j2 + 2*nm - 2

                do
                    if (j2 <= n2m2) exit

                    d1 = abs(b(j1)-b(j2-1))
                    d2 = abs(b(j1)-b(j2))
                    d3 = abs(b(j1)-b(j2+1))

                    if (d1 <= d2 .or. d3 <= d2) then
                        b(lh) = b(j2)
                        j2 = j2 + 1
                        lh = lh + 1
                    else
                        j2 = j2 + 1
                        j1 = j1 + 1
                    end if
                end do

                b(lh) = b(n2m2+1)

                call self%compute_index_b_coeff(iif, k - 1, j1, j2)

                j2 = j1 + nmp + nmp

                associate( order => nm + 1 )
                    call self%compute_eigen_values(ierror, an(1:order), cn(1:order), bc(j1:order), b(j1:order), b(j2:order))
                end associate

            end if

        end associate common_variables

    end subroutine compute_roots_of_b_polynomials

    pure subroutine cprod(nd, bd, nm1, bm1, nm2, bm2, na, aa, x, yy, &
        m, a, b, c, d, w, y)
        !
        ! Purpose:
        !
        ! cprod applies a sequence of matrix operations to the vector x and
        ! stores the result in yy (complex case)
        !
        ! aa   array containing scalar multipliers of the vector x
        !
        ! nd, nm1, nm2 are the lengths of the arrays bd, bm1, bm2 respectively
        !
        ! bd, bm1, bm2 are arrays containing roots of certian b polynomials
        !
        ! na is the length of the array aa
        !
        ! x, yy the matrix operations are applied to x and the result is yy
        !
        ! a, b, c  are arrays which contain the tridiagonal matrix
        !
        ! m  is the order of the matrix
        !
        ! d, w, y are working arrays
        !
        ! isgn  determines whether or not a change in sign is made
        !

        ! Dummy arguments

        integer(ip), intent(in)  :: nd
        integer(ip), intent(in)  :: nm1
        integer(ip), intent(in)  :: nm2
        integer(ip), intent(in)  :: na
        integer(ip), intent(in)  :: m
        real(wp),    intent(in)  :: bm1(nm1)
        real(wp),    intent(in)  :: bm2(nm2)
        real(wp),    intent(in)  :: aa(na)
        real(wp),    intent(in)  :: x(m)
        real(wp),    intent(out) :: yy(m)
        real(wp),    intent(in)  :: a(m)
        real(wp),    intent(in)  :: b(m)
        real(wp),    intent(in)  :: c(m)
        complex(wp), intent(in)  :: bd(nd)
        complex(wp), intent(out) :: d(m)
        complex(wp), intent(out) :: w(m)
        complex(wp), intent(out) :: y(m)

        ! Local variables

        integer(ip) :: j, mm, id, m1, m2, ia, iflg, k
        real(wp)    :: rt
        complex(wp) :: crt, den, y1, y2

        y = cmplx(x, ZERO, kind=wp)

        mm = m - 1
        id = nd
        m1 = nm1
        m2 = nm2
        ia = na

        main_loop: do

            iflg = 0

            if (id > 0) then
                crt = bd(id)
                id = id - 1
                !
                ! begin solution to system
                !
                d(m) = a(m)/(b(m)-crt)
                w(m) = y(m)/(b(m)-crt)

                do j = 2, mm
                    k = m - j
                    den = b(k+1) - crt - c(k+1)*d(k+2)
                    d(k+1) = a(k+1)/den
                    w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den
                end do

                den = b(1) - crt - c(1)*d(2)

                if (abs(den) /= ZERO) then
                    y(1) = (y(1)-c(1)*w(2))/den
                else
                    y(1) = cmplx(ONE, ZERO, kind=wp)
                end if

                y(2:m) = w(2:m) - d(2:m)*y(1:m-1)

            end if

            if (m1 > 0 .and. m2 > 0) then
                if (m1 <= 0) then
                    rt = bm2(m2)
                    m2 = m2 - 1
                else
                    if (m2 <= 0) then
                        rt = bm1(m1)
                        m1 = m1 - 1
                    else
                        if (abs(bm1(m1)) - abs(bm2(m2)) > ZERO) then
                            rt = bm1(m1)
                            m1 = m1 - 1
                        else
                            rt = bm2(m2)
                            m2 = m2 - 1
                        end if
                    end if
                end if
                y1 = (b(1)-rt)*y(1) + c(1)*y(2)
                if (mm >= 2) then
                    do j = 2, mm
                        y2 = a(j)*y(j-1) + (b(j)-rt)*y(j) + c(j)*y(j+1)
                        y(j-1) = y1
                        y1 = y2
                    end do
                end if
                y(m) = a(m)*y(m-1) + (b(m)-rt)*y(m)
                y(m-1) = y1
                iflg = 1
                cycle main_loop
            end if

            if (ia > 0) then
                rt = aa(ia)
                ia = ia - 1
                iflg = 1
                !
                ! scalar multiplication
                !
                y = rt*y
            end if

            if (iflg <= 0) exit main_loop

        end do main_loop

        yy = real(y, kind=wp)

    end subroutine cprod

    pure subroutine cprodp(nd, bd, nm1, bm1, nm2, bm2, na, aa, x, yy, m, a, &
        b, c, d, u, y)
        !
        ! Purpose:
        !
        ! cprodp applies a sequence of matrix operations to the vector x and
        ! stores the result in yy       periodic boundary conditions
        ! and  complex  case
        !
        ! bd, bm1, bm2 are arrays containing roots of certian b polynomials
        ! nd, nm1, nm2 are the lengths of the arrays bd, bm1, bm2 respectively
        ! aa   array containing scalar multipliers of the vector x
        ! na is the length of the array aa
        ! x, yy the matrix operations are applied to x and the result is yy
        ! a, b, c  are arrays which contain the tridiagonal matrix
        ! m  is the order of the matrix
        ! d, u, y are working arrays
        ! isgn  determines whether or not a change in sign is made
        !

        ! Dummy arguments

        integer(ip), intent(in)  :: nd
        integer(ip), intent(in)  :: nm1
        integer(ip), intent(in)  :: nm2
        integer(ip), intent(in)  :: na
        integer(ip), intent(in)  :: m
        real(wp),    intent(in)  :: bm1(nm1)
        real(wp),    intent(in)  :: bm2(nm2)
        real(wp),    intent(in)  :: aa(na)
        real(wp),    intent(in)  :: x(m)
        real(wp),    intent(out) :: yy(m)
        real(wp),    intent(in)  :: a(m)
        real(wp),    intent(in)  :: b(m)
        real(wp),    intent(in)  :: c(m)
        complex(wp), intent(in)  :: bd(nd)
        complex(wp), intent(out) :: d(m)
        complex(wp), intent(out) :: u(m)
        complex(wp), intent(out) :: y(m)

        ! Local variables

        integer(ip) :: j, mm, mm2, id, m1, m2, ia, iflg, k
        real(wp)    :: rt
        complex(wp) :: v, den, bh, ym, am, y1, y2, yh, crt

        y = cmplx(x, ZERO, kind=wp)

        mm = m - 1
        mm2 = m - 2
        id = nd
        m1 = nm1
        m2 = nm2
        ia = na

        main_loop: do

            iflg = 0

            if (id > 0) then
                crt = bd(id)
                id = id - 1
                iflg = 1
                !
                ! begin solution to system
                !
                bh = b(m) - crt
                ym = y(m)
                den = b(1) - crt
                d(1) = c(1)/den
                u(1) = a(1)/den
                y(1) = y(1)/den
                v = cmplx(c(m), ZERO, kind=wp)

                if (mm2 >= 2) then
                    do j = 2, mm2
                        den = b(j) - crt - a(j)*d(j-1)
                        d(j) = c(j)/den
                        u(j) = -a(j)*u(j-1)/den
                        y(j) = (y(j)-a(j)*y(j-1))/den
                        bh = bh - v*u(j-1)
                        ym = ym - v*y(j-1)
                        v = -v*d(j-1)
                    end do
                end if

                den = b(m-1) - crt - a(m-1)*d(m-2)
                d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den
                y(m-1) = (y(m-1)-a(m-1)*y(m-2))/den
                am = a(m) - v*d(m-2)
                bh = bh - v*u(m-2)
                ym = ym - v*y(m-2)
                den = bh - am*d(m-1)

                if (abs(den) /= ZERO) then
                    y(m) = (ym - am*y(m-1))/den
                else
                    y(m) = cmplx(ONE, ZERO, kind=wp)
                end if

                y(m-1) = y(m-1) - d(m-1)*y(m)

                do j = 2, mm
                    k = m - j
                    y(k) = y(k) - d(k)*y(k+1) - u(k)*y(m)
                end do
            end if

            if (m1 > 0 .and. m2 > 0) then
                if (m1 <= 0) then
                    rt = bm2(m2)
                    m2 = m2 - 1
                else
                    if (m2 <= 0) then
                        rt = bm1(m1)
                        m1 = m1 - 1
                    else
                        if (abs(bm1(m1)) - abs(bm2(m2)) > ZERO) then
                            rt = bm1(m1)
                            m1 = m1 - 1
                        else
                            rt = bm2(m2)
                            m2 = m2 - 1
                        !
                        ! matrix multiplication
                        !
                        end if
                    end if
                end if
                yh = y(1)
                y1 = (b(1)-rt)*y(1) + c(1)*y(2) + a(1)*y(m)
                if (mm >= 2) then
                    do j = 2, mm
                        y2 = a(j)*y(j-1) + (b(j)-rt)*y(j) + c(j)*y(j+1)
                        y(j-1) = y1
                        y1 = y2
                    end do
                end if
                y(m) = a(m)*y(m-1) + (b(m)-rt)*y(m) + c(m)*yh
                y(m-1) = y1
                iflg = 1
                cycle main_loop
            end if

            if (ia > 0) then
                rt = aa(ia)
                ia = ia - 1
                iflg = 1
                !
                ! scalar multiplication
                !
                y = rt*y
            end if

            if (iflg <= 0) exit main_loop

        end do main_loop

        yy = real(y, kind=wp)

    end subroutine cprodp

    pure subroutine compute_index_a_coeff(self, i, ir, idxa, na)

        ! Dummy arguments

        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(in)    :: i
        integer(ip),      intent(in)    :: ir
        integer(ip),      intent(out)   :: idxa
        integer(ip),      intent(out)   :: na

        associate( nm => self%nm )
            na = 2**ir
            idxa = i - na + 1
            if (i > nm) na = 0
        end associate

    end subroutine compute_index_a_coeff

    pure subroutine compute_index_b_coeff(self, i, ir, idx, idp)

        ! Dummy arguments

        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(in)    :: i
        integer(ip),      intent(in)    :: ir
        integer(ip),      intent(out)   :: idx
        integer(ip),      intent(out)   :: idp

        ! Local variables

        integer(ip) :: izh, id, ipl

        associate( &
            nm => self%nm, &
            ik => self%ik &
            )
            !
            ! b(idx) is the location of the first root of the b(i, ir) polynomial
            !
            idp = 0

            select case (ir)
                case (0)
                    if (i > nm) then
                        return
                    else
                        idx = i
                        idp = 1
                    end if
                case default
                    if (ir > 0) then
                        izh = 2**ir
                        id = i - 2*izh
                        idx = 2*id + (ir - 1)*ik + ir + (ik - i)/izh + 4
                        ipl = izh - 1
                        idp = 2*izh - 1
                        if (i - ipl - nm > 0) then
                            idp = 0
                            return
                        end if
                        if (i + ipl - nm > 0) idp = nm + ipl - i + 1
                    end if
            end select
        end associate

    end subroutine compute_index_b_coeff

    pure subroutine compute_index_c_coeff(self, i, ir, idxc, nc)

        ! Dummy arguments

        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(in)    :: i
        integer(ip),      intent(in)    :: ir
        integer(ip),      intent(out)   :: idxc
        integer(ip),      intent(out)   :: nc

        associate( nm => self%nm )
            nc = 2**ir
            idxc = i
            if (idxc + nc - 1 - nm > 0) nc = 0
        end associate

    end subroutine compute_index_c_coeff

    ! Purpose
    !
    ! Computes the eigenvalues of the periodic tridiagonal matrix
    ! with coefficients an, bn, cn
    !
    ! n is the order of the bh and bp polynomials
    ! on output bp contains the eigenvalues
    ! cbp is the same as bp except type complex
    ! bh is used to temporarily store the roots of the b hat polynomial
    ! which enters through bp
    !
    subroutine compute_eigen_values(self, ierror, a, c, cbp, bp, bh)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(out)   :: ierror
        real(wp),         intent(in)    :: a(:)
        real(wp),         intent(in)    :: c(:)
        real(wp),         intent(inout) :: bp(:)
        real(wp),         intent(inout) :: bh(:)
        complex(wp),      intent(inout) :: cbp(:)

        ! Local variables
        integer(ip)   :: iz, izm, izm2, j, nt, modiz, is
        integer(ip)   :: iif, ig, it, icv, i3, i2, nhalf
        real(wp)      :: r4, r5, r6, scnv, xl, db, sgn, xr, xm, psg
        real(wp)      :: temp
        complex(wp)   :: cx, fsg, hsg, dd, f, fp, fpp, cdis, r1, r2, r3

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ncmplx=> self%ncmplx, &
            ik => self%ik, &
            cnv => self%cnv &
            )

            associate( n => size(a) )

                scnv = sqrt(cnv)
                iz = n
                izm = iz - 1
                izm2 = iz - 2

                if (bp(n) <= bp(1)) then
                    if (bp(n) == bp(1)) then
                        ierror = 4
                        return
                    else
                        bh(:n) = bp(n:1:(-1))
                    end if
                else
                    bh(:n) = bp(:n)
                end if

                ncmplx = 0
                modiz = mod(iz, 2)
                is = 1

                if (modiz /= 0) then
                    if (a(1) >= ZERO) then
                        if (a(1) == ZERO) then
                            ierror = 4
                            return
                        end if
                    end if

                    xl = bh(1)
                    db = bh(3) - bh(1)
                    xl = xl - db
                    r4 = self%psgf(xl, iz, c, a, bh)

                    do
                        if (ZERO < r4) exit
                        xl = xl - db
                        r4 = self%psgf(xl, iz, c, a, bh)
                    end do

                    sgn = -ONE

                    temp = self%bsrh(xl, bh(1), iz, c, a, bh, sgn, psgf)

                    cbp(1) = cmplx(temp, ZERO, kind=wp)

                    bp(1) = real(cbp(1), kind=wp)

                    is = 2

                end if

                iif = iz - 1

                if (modiz /= 0) then

                    if (a(1) == ZERO) then
                        ierror = 4
                        return
                    end if

                    xr = bh(iz)
                    db = bh(iz) - bh(iz-2)
                    xr = xr + db
                    r5 = self%psgf(xr, iz, c, a, bh)

                    do
                        if (ZERO <= r5) exit
                        xr = xr + db
                        r5 = self%psgf(xr, iz, c, a, bh)
                    end do

                    sgn = ONE
                    temp = self%bsrh(bh(iz), xr, iz, c, a, bh, sgn, psgf)

                    cbp(iz) = cmplx(temp, ZERO, kind=wp)
                    iif = iz - 2

                end if

                main_loop: do ig = is, iif, 2

                    xl = bh(ig)
                    xr = bh(ig+1)
                    sgn = -ONE
                    xm = self%bsrh(xl, xr, iz, c, a, bh, sgn, ppspf)
                    psg = self%psgf(xm, iz, c, a, bh)

                    block_construct: block

                        if (abs(psg) > MACHINE_EPSILON) then

                            r6 = psg*self%psgf(xm, iz, c, a, bh)

                            if (r6 > ZERO) exit block_construct

                            if (r6 /= ZERO) then

                                sgn = ONE
                                temp = self%bsrh(bh(ig), xm, iz, c, a, bh, sgn, psgf)
                                cbp(ig) = cmplx(temp, ZERO, kind=wp)
                                sgn = -ONE
                                temp = self%bsrh(xm, bh(ig+1), iz, c, a, bh, sgn, psgf)
                                cbp(ig+1) = cmplx(temp, ZERO, kind=wp)

                                cycle main_loop
                            !
                            ! Case of a multiple zero
                            !
                            end if
                        end if

                        cbp(ig) = cmplx(xm, ZERO, kind=wp)
                        cbp(ig+1) = cmplx(xm, ZERO, kind=wp)

                        cycle main_loop
                    !
                    ! case of a complex zero
                    !
                    end block block_construct

                    it = 0
                    icv = 0
                    cx = cmplx(xm, ZERO, kind=wp)

                    loop_120: do

                        fsg = cmplx(ONE, ZERO, kind=wp)
                        hsg = cmplx(ONE, ZERO, kind=wp)
                        fp = ZERO
                        fpp = ZERO

                        do j = 1, iz
                            dd = ONE/(cx - bh(j))
                            fsg = fsg*a(j)*dd
                            hsg = hsg*c(j)*dd
                            fp = fp + dd
                            fpp = fpp - dd**2
                        end do

                        select case (modiz)
                            case (0)
                                f = cmplx(ONE, ZERO, kind=wp) - fsg - hsg
                            case default
                                f = cmplx(ONE, ZERO, kind=wp) + fsg + hsg
                        end select

                        i3 = 0

                        if (abs(fp) > ZERO) then
                            i3 = 1
                            r3 = -f/fp
                        end if

                        i2 = 0

                        if (abs(fpp) > ZERO) then

                            i2 = 1
                            cdis = sqrt((fp**2) - TWO * f * fpp)
                            r1 = cdis - fp
                            r2 = (-fp) - cdis

                            if (abs(r1) - abs(r2) > ZERO) then
                                r1 = r1/fpp
                            else
                                r1 = r2/fpp
                            end if

                            r2 = ((TWO*f)/fpp)/r1

                            if (abs(r2) < abs(r1)) r1 = r2

                            if (i3 > 0 .and. abs(r3) < abs(r1)) r1 = r3

                        else
                            r1 = r3
                        end if

                        cx = cx + r1
                        it = it + 1

                        if (it > 50) then
                            ierror = 4
                            return
                        end if

                        if (abs(r1) > scnv) cycle loop_120

                        if (icv <= 0) then
                            icv = 1
                            cycle loop_120
                        end if

                        exit loop_120
                    end do loop_120

                    cbp(ig) = cx
                    cbp(ig+1) = conjg(cx)

                end do main_loop

                if (abs(cbp(n)) - abs(cbp(1)) <= ZERO) then
                    if (abs(cbp(n)) - abs(cbp(1)) == ZERO) then
                        ierror = 4
                        return
                    end if

                    nhalf = n/2
                    do j = 1, nhalf
                        nt = n - j
                        cx = cbp(j)
                        cbp(j) = cbp(nt+1)
                        cbp(nt+1) = cx
                    end do
                end if

                ncmplx = 1

                if (any(aimag(cbp(2:iz)) /= ZERO)) return

                ncmplx = 0
                bp(1) = real(cbp(1), kind=wp)
                bp(2:iz) = real(cbp(2:iz))

            end associate

        end associate common_variables

    end subroutine compute_eigen_values

    ! Purpose:
    !
    ! Applies a sequence of matrix operations to the vector x and
    ! stores the result in y
    ! bd, bm1, bm2 are arrays containing roots of certian b polynomials
    ! nd, nm1, nm2 are the lengths of the arrays bd, bm1, bm2 respectively
    ! aa   array containing scalar multipliers of the vector x
    ! na is the length of the array aa
    ! x, y  the matrix operations are applied to x and the result is y
    ! a, b, c  are arrays which contain the tridiagonal matrix
    ! m  is the order of the matrix
    ! d, w, u are working arrays
    ! is  determines whether or not a change in sign is made
    !
    pure subroutine prod(nd, bd, nm1, bm1, nm2, bm2, na, aa, x, y, m, a, b, c, d, w, u)

        ! Dummy arguments
        integer(ip), intent(in)  :: nd
        integer(ip), intent(in)  :: nm1
        integer(ip), intent(in)  :: nm2
        integer(ip), intent(in)  :: na
        integer(ip), intent(in)  :: m
        real(wp),    intent(in)  :: bd(nd)
        real(wp),    intent(in)  :: bm1(nm1)
        real(wp),    intent(in)  :: bm2(nm2)
        real(wp),    intent(in)  :: aa(na)
        real(wp),    intent(in)  :: x(m)
        real(wp),    intent(out) :: y(m)
        real(wp),    intent(in)  :: a(m)
        real(wp),    intent(in)  :: b(m)
        real(wp),    intent(in)  :: c(m)
        real(wp),    intent(out) :: d(m)
        real(wp),    intent(out) :: w(m)
        real(wp),    intent(out) :: u(m)

        ! Local variables
        integer(ip) :: j, mm, id, ibr, m1, m2, ia, k
        real(wp)    :: rt, den

        w = x
        y = w
        mm = m - 1
        id = nd
        ibr = 0
        m1 = nm1
        m2 = nm2
        ia = na

        main_loop: do

            if (ia > 0) then

                if (nd == 0) then
                    rt = -aa(ia)
                else
                    rt = aa(ia)
                end if

                ia = ia - 1
                !
                ! scalar multiplication
                !
                y = rt*w
            end if

            if (id <= 0) return

            rt = bd(id)
            id = id - 1

            if (id == 0) ibr = 1

            !
            ! begin solution to system
            !
            d(m) = a(m)/(b(m)-rt)
            w(m) = y(m)/(b(m)-rt)

            do j = 2, mm
                k = m - j
                den = b(k+1) - rt - c(k+1)*d(k+2)
                d(k+1) = a(k+1)/den
                w(k+1) = (y(k+1)-c(k+1)*w(k+2))/den
            end do

            den = b(1) - rt - c(1)*d(2)
            w(1) = ONE

            if (den /= ZERO) w(1) = (y(1)-c(1)*w(2))/den

            do j = 2, m
                w(j) = w(j) - d(j)*w(j-1)
            end do

            if (na > 0) cycle main_loop

            if (m1 <= 0) then
                if (m2 <= 0) then
                    y = w
                    ibr = 1
                    cycle main_loop
                end if
            else
                if (.not.(m2 > 0 .and. abs(bm1(m1)) <= abs(bm2(m2)))) then
                    if (ibr <= 0) then
                        if (abs(bm1(m1)-bd(id)) < abs(bm1(m1)-rt)) then
                            y(:m) = w(:m)
                            ibr = 1
                            cycle main_loop
                        end if
                    end if
                    rt = rt - bm1(m1)
                    m1 = m1 - 1
                    y = y + rt*w
                    cycle main_loop
                end if
            end if

            if (ibr <= 0 .and. abs(bm2(m2)-bd(id)) < abs(bm2(m2)-rt)) then
                y = w
                ibr = 1
                cycle main_loop
            end if

            rt = rt - bm2(m2)
            m2 = m2 - 1
            y = y + rt*w

        end do main_loop

    end subroutine prod

    ! Purpose:
    !
    ! Applies a sequence of matrix operations to the vector x and
    ! stores the result in y periodic boundary conditions
    !
    ! bd, bm1, bm2 are arrays containing roots of certain b polynomials
    !
    ! nd, nm1, nm2 are the lengths of the arrays bd, bm1, bm2 respectively
    !
    ! aa   array containing scalar multipliers of the vector x
    !
    ! na is the length of the array aa
    !
    ! x, y  the matrix operations are applied to x and the result is y
    !
    ! a, b, c  are arrays which contain the tridiagonal matrix
    !
    ! m  is the order of the matrix
    !
    ! d, u, w are working arrays
    !
    ! is  determines whether or not a change in sign is made
    !
    pure subroutine prodp(nd, bd, nm1, bm1, nm2, bm2, na, aa, x, y, m, a, b, c, d, u, w)

        ! Dummy arguments
        integer(ip), intent(in)  :: nd
        integer(ip), intent(in)  :: nm1
        integer(ip), intent(in)  :: nm2
        integer(ip), intent(in)  :: na
        integer(ip), intent(in)  :: m
        real(wp),    intent(in)  :: bd(nd)
        real(wp),    intent(in)  :: bm1(nm1)
        real(wp),    intent(in)  :: bm2(nm2)
        real(wp),    intent(in)  :: aa(na)
        real(wp),    intent(in)  :: x(m)
        real(wp),    intent(out) :: y(m)
        real(wp),    intent(in)  :: a(m)
        real(wp),    intent(in)  :: b(m)
        real(wp),    intent(in)  :: c(m)
        real(wp),    intent(out) :: d(m)
        real(wp),    intent(out) :: u(m)
        real(wp),    intent(out) :: w(m)

        ! Local variables
        integer(ip) :: j, mm, mm2, id, ibr, m1, m2, ia, k
        real(wp)    :: rt, bh, ym, den, v, am

        y = x
        w = y
        mm = m - 1
        mm2 = m - 2
        id = nd
        ibr = 0
        m1 = nm1
        m2 = nm2
        ia = na

        main_loop: do

            if (ia > 0) then
                rt = aa(ia)

                if (nd == 0) rt = -rt

                ia = ia - 1
                y = rt*w
            end if

            if (id <= 0) return

            rt = bd(id)
            id = id - 1

            if (id == 0) ibr = 1

            !
            ! begin solution to system
            !
            bh = b(m) - rt
            ym = y(m)
            den = b(1) - rt
            d(1) = c(1)/den
            u(1) = a(1)/den
            w(1) = y(1)/den
            v = c(m)

            if (mm2 >= 2) then
                do j = 2, mm2
                    den = b(j) - rt - a(j)*d(j-1)
                    d(j) = c(j)/den
                    u(j) = -a(j)*u(j-1)/den
                    w(j) = (y(j)-a(j)*w(j-1))/den
                    bh = bh - v*u(j-1)
                    ym = ym - v*w(j-1)
                    v = -v*d(j-1)
                end do
            end if

            den = b(m-1) - rt - a(m-1)*d(m-2)
            d(m-1) = (c(m-1)-a(m-1)*u(m-2))/den
            w(m-1) = (y(m-1)-a(m-1)*w(m-2))/den
            am = a(m) - v*d(m-2)
            bh = bh - v*u(m-2)
            ym = ym - v*w(m-2)
            den = bh - am*d(m-1)

            if (den /= ZERO) then
                w(m) = (ym - am*w(m-1))/den
            else
                w(m) = ONE
            end if

            w(m-1) = w(m-1) - d(m-1)*w(m)

            do j = 2, mm
                k = m - j
                w(k) = w(k) - d(k)*w(k+1) - u(k)*w(m)
            end do

            if (na <= 0) then
                if (m1 <= 0 .and. m2 <= 0) then
                    y = w
                    ibr = 1
                    cycle main_loop
                else

                    if (m2 > 0 .and. abs(bm1(m1)) - abs(bm2(m2)) <= ZERO) then
                        if (ibr <= 0 .and. abs(bm2(m2)-bd(id)) - abs(bm2(m2)-rt) < ZERO) then
                            y = w
                            ibr = 1
                            cycle main_loop
                        else
                            rt = rt - bm2(m2)
                            m2 = m2 - 1
                            y = y + rt*w
                        end if
                    end if

                    if (ibr <= 0 .and. abs(bm1(m1)-bd(id)) - abs(bm1(m1)-rt) < ZERO) then
                        y = w
                        ibr = 1
                        cycle main_loop
                    else
                        rt = rt - bm1(m1)
                        m1 = m1 - 1
                        y = y + rt*w
                        cycle main_loop
                    end if
                end if

                if (ibr <= 0 .and. abs(bm2(m2)-bd(id)) - abs(bm2(m2)-rt) < ZERO) then
                    y = w
                    ibr = 1
                else
                    rt = rt - bm2(m2)
                    m2 = m2 - 1
                    y = y + rt*w
                end if
            end if
        end do main_loop

    end subroutine prodp

    ! Purpose:
    !
    !     This subroutine is a modification of the eispack subroutine tqlrat
    !     algorithm 464, comm. acm 16, 689(1973) by reinsch.
    !
    !     this subroutine finds the eigenvalues of a symmetric
    !     tridiagonal matrix by the rational ql method.
    !
    !     on input-
    !
    !        d contains the diagonal elements of the input matrix,
    !
    !        e2 contains the subdiagonal elements of the
    !          input matrix in its last n-1 positions.  e2(1) is arbitrary.
    !
    !      on output-
    !
    !        d contains the eigenvalues in ascending order.  if an
    !          error exit is made, the eigenvalues are correct and
    !          ordered for indices 1, 2, ...error_flag-1, but may not be
    !          the smallest eigenvalues,
    !
    !        e2 has been destroyed,
    !
    !        error_flag is set to
    !          zero       for normal return,
    !          j          if the j-th eigenvalue has not been
    !                     determined after 30 iterations.
    !
    !     questions and comments should be directed to b. s. garbow,
    !     applied mathematics division, argonne national laboratory
    !
    !
    !     eps is a machine dependent parameter specifying
    !     the relative precision of floating point arithmetic.
    !
    subroutine tevls(self, diagonal, subdiagonal, error_flag)

        ! Dummy arguments
        class(GeneralizedCyclicReductionUtility), intent(inout) :: self
        integer(ip),      intent(out)   :: error_flag
        real(wp),         intent(inout) :: diagonal(:)
        real(wp),         intent(inout) :: subdiagonal(:)

        ! Local variables
        integer(ip) :: i, j, l, m, ii, l1, mml, nhalf, ntop
        real(wp)    :: b, c, f, g, h, p, r, s, dhold

        common_variables: associate( &
            npp => self%npp, &
            k => self%k, &
            nm => self%nm, &
            ncmplx=> self%ncmplx, &
            ik => self%ik, &
            cnv => self%cnv &
            )

            error_flag = 0

            associate( &
                n => size(diagonal), &
                d => diagonal, &
                e2 => subdiagonal &
                )

                if (n == 1) return

                e2(:n-1) = e2(2:n)**2
                f = ZERO
                b = ZERO
                e2(n) = ZERO

                main_loop: do l = 1, n
                    j = 0
                    h = MACHINE_EPSILON*(abs(d(l))+sqrt(e2(l)))

                    if (b <= h) then
                        b = h
                        c = b**2
                    end if
                    !
                    !  look for small squared sub-diagonal element
                    !
                    do m = l, n
                        if (e2(m) > c) then
                            cycle
                        end if
                        exit
                    !
                    ! e2(n) is always zero, so there is no exit
                    !    through the bottom of the loop
                    !
                    end do

                    if_construct: if (m /= l) then

                        loop_105: do

                            if (j == 30) then
                                !
                                ! set error: no convergence to an
                                !    eigenvalue after 30 iterations
                                !
                                error_flag = l
                                return
                            end if

                            j = j + 1
                            !
                            ! form shift
                            !
                            l1 = l + 1
                            s = sqrt(e2(l))
                            g = d(l)
                            p = (d(l1)-g)/(2.0*s)
                            r = sqrt(p**2 + ONE)
                            d(l) = s/(p + sign(r, p))
                            h = g - d(l)
                            d(l1:n) = d(l1:n) - h
                            f = f + h
                            !
                            ! rational ql transformation
                            !
                            if (g == ZERO) then
                                g = b
                            else
                                g = d(m)
                            end if

                            h = g
                            s = ZERO
                            mml = m - l
                            !
                            ! for i = m-1 step -1 until l do
                            !
                            do ii = 1, mml
                                i = m - ii
                                p = g*h
                                r = p + e2(i)
                                e2(i+1) = s*r
                                s = e2(i)/r
                                d(i+1) = h + s*(h + d(i))
                                g = d(i) - e2(i)/g

                                if (g == ZERO) g = b

                                h = g*p/r
                            end do
                            !
                            e2(l) = s*g
                            d(l) = h
                            !
                            ! guard against underflowed h
                            !
                            if (h == ZERO) exit if_construct

                            if (abs(e2(l)) <= abs(c/h)) exit if_construct

                            e2(l) = h*e2(l)

                            if (e2(l) == ZERO) exit loop_105

                        end do loop_105
                    end if if_construct

                    p = d(l) + f
                    !
                    ! order eigenvalues
                    !
                    if (l /= 1) then
                        !
                        ! for i=l step -1 until 2 do
                        !
                        do ii = 2, l
                            i = l + 2 - ii
                            if (p >= d(i-1)) then
                                d(i) = p
                                cycle main_loop
                            else
                                d(i) = d(i-1)
                            end if
                        end do
                    end if

                    i = 1
                    d(i) = p

                end do main_loop

                if (abs(d(n)) < abs(d(1))) then
                    nhalf = n/2
                    do i = 1, nhalf
                        ntop = n - i
                        dhold = d(i)
                        d(i) = d(ntop+1)
                        d(ntop+1) = dhold
                    end do
                end if

            end associate
        end associate common_variables

    end subroutine tevls

end module type_GeneralizedCyclicReductionUtility


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_sssym
!-----------------------------------------------------------------------!
! tests the compatibility of the symmetry elements with the axis (q)    !
! defining a spin-sprial                                          gb`02 !
!-----------------------------------------------------------------------!
      CONTAINS
      SUBROUTINE ss_sym(
     >                  nop,mrot,qss,
     <                  error)

      USE m_constants
      IMPLICIT NONE

      INTEGER, INTENT (IN)  :: nop, mrot(3,3,nop)
      REAL,    INTENT (IN)  :: qss(3)
      LOGICAL, iNTENT (OUT) :: error(nop)

      INTEGER iop,i,j
      REAL    qn,test
      REAL    q1(3),rrot(3,3)

!
! --> loop over symmetry elements
!
      error(:) = .false.
      qn = ( qss(1)**2 + qss(2)**2 + qss(3)**2 )

      IF (qn.LT.0.0000001) THEN
        WRITE(*,*) 'qss = 0 ; not a spin-spiral!'
        RETURN
      ELSE
        qn = 1.0 / qn
      ENDIF

      DO iop = 1, nop

        DO i=1,3
           DO j=1,3
              rrot(i,j)= REAL(mrot(i,j,iop))
           ENDDO
        ENDDO
!
! ----> rotate qss by symmetry element and form the dot-product
!       with unrotated vector (q1 . qss)
!
         q1=matmul(qss,rrot)
!
! ----> if qss is unchanged, accept this symmetry element
!
        test = (qss(1)-q1(1))**2+(qss(2)-q1(2))**2+(qss(3)-q1(3))**2
        IF (abs(test).GT.0.0000001) THEN
          error(iop) = .true.
          WRITE (oUnit,100) iop
        ENDIF
      ENDDO
 100  FORMAT ('Symmetry element no.',i3,' incompatible with axis qss')

      IF ( ANY(error(:)) ) THEN
        WRITE (oUnit,*)
     +     'symmetry incompatible with Spin Spiral Axis [qss]'
      ENDIF
      END SUBROUTINE ss_sym
      END MODULE m_sssym


module ColorPalette

    USE DFLIB
    use Projection
    use HealPix

    integer, parameter :: aR = 0       ! RGB for our 1st color (blue in this case).
    integer, parameter :: aG = 0
    integer, parameter :: aB = 0
    integer, parameter :: bR = 255     ! RGB for our 2nd color (yellow in this case).
    integer, parameter :: bG = 255
    integer, parameter :: bB = 255

    contains

    function GetColorGradVect(value,valueexp) result(res)

        real(8), dimension(:) :: value
        integer, dimension(size(value)) :: red, green, blue
        integer, dimension(size(value)) :: res
        real(8) :: valueexp

        value = value**valueexp

        red   = (bR - aR) * value + aR      ! Evaluated as -255*value + 255.
        green = (bG - aG) * value + aG      ! Evaluates as 0.
        blue  = (bB - aB) * value + aB      ! Evaluates as 255*value + 0.

        res = red + 256*green + 65536*blue

    end function GetColorGradVect

    function GetColorGrad(value,valueexp) result(res)

        real(8) :: value, valueexp
        integer :: red, green, blue
        integer :: res

        value = value**valueexp

        red   = (bR - aR) * value + aR      ! Evaluated as -255*value + 255.
        green = (bG - aG) * value + aG      ! Evaluates as 0.
        blue  = (bB - aB) * value + aB      ! Evaluates as 255*value + 0.

        res = red + 256*green + 65536*blue

    end function GetColorGrad

    function GetWColorGrad(value) result(res)

        real(8) :: value, valueexp
        integer :: red, green, blue
        integer :: res

        red   = 255 * value      ! Evaluated as -255*value + 255.
        green = 255 * value      ! Evaluates as 0.
        blue  = 255 * value      ! Evaluates as 255*value + 0.

        res = red + 256*green + 65536*blue

    end function GetWColorGrad

    subroutine DrawHealpix(ipixcolor,nside)

    integer, dimension(0:) :: ipixcolor
    real(8) :: l,b,x,y
    integer :: i,j,status,k

    !!$omp parallel private(b,l,x,y)
    !!$omp do
    do i = 0, 3500!*3600
        do j = 0, 4000!*3600
            l = -halfpi+halfpi*i/(1750)!*3600)
            b = -4.0*atan(1.0)+4.0*atan(1.0)*j/(2000)!*3600)
            call ang2pix_ring(nside, b, l, k)
            call Aitoff(b,l,x,y)
            !!$omp critical
            status = setcolorrgb(ipixcolor(k))
            status = rectangle($GFILLINTERIOR,x,y,x,y)
            !!$omp end critical
        enddo
    enddo
    !!$omp end do
    !!$omp end parallel

    end subroutine DrawHealpix

    subroutine DrawLegend(name,meddist,pos)

    character(32) :: name
    character(8) :: legnum
    real(8), dimension(:) :: meddist
    integer :: i
    logical(4) :: status
    TYPE (windowconfig) wc
    real(8) :: colorgrad, valueexp
    TYPE (xycoord) pos

    valueexp = 1.0

    status = getwindowconfig(wc)

    do i = 0, 255
        colorgrad = i/255.0
        status = setcolorrgb(#000000)
        if((i/64.0-i/64).eq.0)then
            status = rectangle($GFILLINTERIOR,2*i+20,wc%numypixels-125,2*i+20,wc%numypixels-100)
        endif
        status = setcolorrgb(GetColorGrad(colorgrad,valueexp))
        status = rectangle($GFILLINTERIOR,2*i+20,wc%numypixels-100,2*(i+1)+20,wc%numypixels)
    enddo
    status = setcolorrgb(#000000)
    call moveto(10,wc%numypixels-215,pos)
    call outgtext(trim(name))
    call moveto(10,wc%numypixels-170,pos)
    call outgtext("0")
    call moveto(2*64,wc%numypixels-170,pos)
    write(legnum,"(F3.1)") maxval(meddist)/4000.0
    call outgtext(legnum)
    call moveto(2*128,wc%numypixels-170,pos)
    write(legnum,"(F3.1)") maxval(meddist)/2000.0
    call outgtext(legnum)
    call moveto(2*192,wc%numypixels-170,pos)
    write(legnum,"(F3.1)") maxval(meddist)/4000.0*3
    call outgtext(legnum)
    call moveto(2*i,wc%numypixels-170,pos)
    write(legnum,"(F3.1)") maxval(meddist)/1000.0
    call outgtext(legnum)
    status = rectangle($GFILLINTERIOR,2*i+20,wc%numypixels-125,2*i+20,wc%numypixels-100)

    end subroutine DrawLegend

end module ColorPalette


!==============================================================================!
  subroutine Residual(N, NB, A, x, r1)
!------------------------------------------------------------------------------!
!   Calculates residuals.                                                      !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use par_mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: N, NB
  type(Matrix_Type) :: A
  real              :: x(-NB:N), r1(N)  !  [A]{x}={r1}
!-----------------------------------[Locals]-----------------------------------!
  integer  :: i,j,k,sub
!==============================================================================!

  !----------------!
  !   r = b - Ax   !
  !----------------!
  do i=1,N
    do j=A % row(i),A % row(i+1)-1
      k = A % col(j)
      r1(i) = r1(i) - A % val(j) * x(k)
    end do
  end do

! call exchange(x)

  do sub=1,n_proc
    if(NBBe(sub)  <=  NBBs(sub)) then
      do k=NBBs(sub),NBBe(sub),-1
        i=BufInd(k)
        r1(i) = r1(i) - A % bou(k)*x(k)
      end do
    end if
  end do

  end subroutine


PROGRAM driver

  use sp_hnfs, only: so_32
  use num_types

  implicit none

  integer :: n, i, j
  integer, allocatable :: spHNFs(:,:,:)
  real(dp), pointer :: B_vecs(:,:)
  integer :: at(1)
  integer :: Co(3,3), Cu(3,3)
  real(dp) :: No(3,3), Nu(3,3), O(3,3), U(3,3), offsets(1,3)
  integer :: n_irr, nhnfs
  real(dp) :: grid(3,3), best_offset(3)
  logical :: all_hnfs

  n = 100
  allocate(B_vecs(1,3))
  B_vecs(1,:) = (/ 0.0_dp, 0.0_dp, 0.0_dp /)
  offsets(1,:) = (/ 0.0_dp, 0.0_dp, 0.0_dp /)
  at(1) = 0
  all_hnfs = .True.

  Co(1,:) = (/ 1, 0, 0 /)
  Co(2,:) = (/ 0, 1, 0 /)
  Co(3,:) = (/ 0, 0, 1 /)

  Cu(1,:) = (/ 1, 0, 0 /)
  Cu(2,:) = (/ 0, 1, 0 /)
  Cu(3,:) = (/ 0, 0, 1 /)

  No(1,:) = (/1.0_dp, 0.0_dp, 0.0_dp /)
  No(2,:) = (/0.0_dp, 1.0_dp, 0.0_dp /)
  No(3,:) = (/0.0_dp, 0.0_dp, 1.0_dp /)

  Nu(1,:) = (/1.0_dp, 0.0_dp, 0.0_dp /)
  Nu(2,:) = (/0.0_dp, 1.0_dp, 0.0_dp /)
  Nu(3,:) = (/0.0_dp, 0.0_dp, 1.0_dp /)

  O(1,:) = (/1.0_dp, 0.0_dp, 0.0_dp /)
  O(2,:) = (/0.0_dp, 1.0_dp, 0.0_dp /)
  O(3,:) = (/0.0_dp, 0.0_dp, 1.0_dp /)

  U(1,:) = (/1.0_dp, 0.0_dp, 0.0_dp /)
  U(2,:) = (/0.0_dp, 1.0_dp, 0.0_dp /)
  U(3,:) = (/0.0_dp, 0.0_dp, 1.0_dp /)

  call so_32(n, No, Nu, Co, Cu, O, U, B_vecs, at, offsets, best_offset, spHNFs, grid, &
       n_irr, nhnfs, all_hnfs_=all_hnfs)

  open(3, file="HNFs.out")
  do i= 1,nhnfs
     write(3,'(6i6)') spHNFs(1,1,i), spHNFs(2,1,i), spHNFs(2,2,i), spHNFs(3,1,i), spHNFs(3,2,i), spHNFs(3,3,i)
  end do
  close(3)

end PROGRAM driver


C SS2ONF.F - Gateway function for the conversion of a linear
C            discrete-time system into the output normal form
C            using SLICOT routine TB01VD.
C
C RELEASE 2.0 of SLICOT System Identification Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   theta = ss2onf(A,B,C,D,x0,apply)
C
C Purpose:
C  To convert the linear discrete-time system given as (A, B, C, D),
C  with initial state x0, into the output normal form, with parameter
C  vector theta. The matrix A is assumed to be stable.
C  Optionally, a bijective transformation is used, guaranteeing that
C  the inverse conversion (using ONF2SS) can always be performed.
C
C Input parameters:
C   A      - the n-by-n state matrix A.
C   B      - the n-by-m input matrix B.
C   C      - the l-by-n output matrix C.
C   D      - the l-by-m input-output matrix D.
C   x0     - the initial state.
C   apply  - (optional) integer specifying whether or not the parameter
C            vector should be transformed using a bijective mapping:
C            = 1: apply the bijective mapping to the n vectors in
C                 theta corresponding to the matrices A and C;
C            = 0: do not apply the bijective mapping.
C            Default:  apply = 0.
C
C Output parameters:
C   theta  - the n*(l+m+1)+l*m parameter vector.
C
C Contributors:
C   A. Riedel, R. Schneider, Chemnitz Univ. of Technology, Mar. 2001.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001,
C   Feb. 2002, Apr. 2009, Dec. 2012.
C
C **********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         APPLY
      INTEGER           INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M,
     $                  N
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), B(:,:), C(:,:), D(:,:),
     $                                 DWORK(:), THETA(:), X0(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      INTEGER           ITMP
      DOUBLE PRECISION  TEMP
C
C .. External subroutines ..
      EXTERNAL          TB01VD
C
C .. Intrinsic functions ..
      INTRINSIC         MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SS2ONF requires at least 5 input arguments' )
      ELSE IF ( NLHS.LT.1 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SS2ONF requires 1 output argument' )
      END IF
C
C   A(nxn), B(nxm), C(lxn), D(lxm), x0(n), apply.
C
      N = mxGetM( PRHS(1) )
      M = mxGetN( PRHS(2) )
      L = mxGetM( PRHS(3) )
C
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
      IF ( mxGetN( PRHS(1) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a real matrix' )
      END IF
      IF ( mxGetM( PRHS(2) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'B must have the same number of rows as A' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a real matrix' )
      END IF
      IF ( mxGetN( PRHS(3) ).NE.N ) THEN
         CALL mexErrMsgTxt
     $           ( 'C must have the same number of columns as A' )
      END IF
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'D must be a real matrix' )
      END IF
      IF ( mxGetM( PRHS(4) ).NE.L ) THEN
         CALL mexErrMsgTxt( 'D must have the same number of rows as C' )
      END IF
      IF ( mxGetN( PRHS(4) ).NE.M ) THEN
         CALL mexErrMsgTxt
     $           ( 'D must have the same number of columns as B' )
      END IF
      IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(5) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'X0 must be a real matrix' )
      END IF
      IF ( mxGetM( PRHS(5) )*mxGetN( PRHS(5) ).LT.N ) THEN
         WRITE( TEXT, '(''X0 must have '',I7,'' entries'')' ) N
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      ITMP = 0
      IF ( NRHS.GE.6 ) THEN
         IF ( mxGetM( PRHS(6) ).NE.1 .OR.
     $        mxGetN( PRHS(6) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'APPLY must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(6) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'APPLY must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), TEMP, 1 )
         ITMP = TEMP
         IF ( ITMP.LT.0 .OR. ITMP.GT.1 ) THEN
            CALL mexErrMsgTxt
     $              ( 'APPLY has 0 and 1 the only admissible values' )
         END IF
      END IF
      IF ( ITMP.EQ.0 ) THEN
         APPLY = 'N'
      ELSE
         APPLY = 'A'
      END IF
C
C Determine the lenghts of working arrays.
C
      LDA = MAX( 1, N )
      LDB = LDA
      LDC = MAX( 1, L )
      LDD = LDC
C
      LTHETA = N*( L + M + 1 ) + L*M
      LDWORK = MAX( 1, N*N*L + N*L + N,
     $              N*N + MAX( N*( N + MAX( N, L ) + 6 ) + MIN( N, L ),
     $                         N*M ) )
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( A( LDA, N ), B( LDB, M ), C( LDC, N ), D( LDD, M ),
     $           DWORK( LDWORK ), THETA( LTHETA ), X0( N ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), C, L*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), D, L*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), X0, N )
C
C Do the actual computations.
C
      CALL TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, X0,
     $             THETA, LTHETA, DWORK, LDWORK, INFO )
C
C Copy output to MATLAB workspace.
C
      PLHS(1) = mxCreateDoubleMatrix( LTHETA, 1, 0 )
      CALL mxCopyReal8ToPtr( THETA, mxGetPr( PLHS(1) ), LTHETA )
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE( A, B, C, D, DWORK, THETA, X0 )
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM TB01VD'')'
     $        ) INFO
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of SS2ONF ***
      END


C    @(#)bprim.f	20.3 2/13/96
      subroutine bprim

C     THIS SUBROUTINE SETS UP THE B' MATRIX

      include 'ipfinc/parametr.inc'

      include 'ipfinc/apcom.inc'
      include 'ipfinc/lfiles.inc'
      include 'ipfinc/time1.inc'

C     TEMPORARY ARRAYS FOR B-PRIME MATRIX
C     ARRAYS BP SHOULD BE DIMENSIONED
C     2*(MAX NUMBER OF NODES + MAX NUMBER OF BRANCHES)

      common /cpwork/ ipbp(MXCPBS), bp(MXCPBS+2*MXYBR),
     1                jbp(MXCPBS+2*MXYBR)
C
      ib = 1
      do 1850 k=2,nbus
         k1 = k-1
         ipbp(k1) = ib

C        IPBP CONTAINS THE STARTING ADDRESS OF THE K1TH ROW
C        FOR THE B-PRIME MATRIX

         bkk = 0.
         iptr = ipyl(1,k)
         kl = ipyl(2,k)
C
C        LOOP OVER ALL THE BRANCHES CONNECTED TO NODE K
C        IN THE LOWER TRIANGLE
C
         do 1500 l=1,kl
            m1 = mfarl(iptr) - 1
            bkm = -ykml(2,iptr)
            bkk = bkk + bkm

C           IGNORE THIS ENTRY IF THE FAR-END NODE IS NODE 0

            if (m1.eq.0) go to 1500

C           STORE B-PRIME ELEMENT. COLUMN NUMBER AND VALUE.

            jbp(ib) = m1
            bp(ib) = -bkm
            ib = ib+1
 1500    iptr = iptr + 1
C
C        LOOP OVER ALL THE BRANCHES CONNECTED TO NODE K
C        IN THE UPPER TRIANGLE
C
         iptr = ipyu(1,k)
         kl = ipyu(2,k)
C
         do 1700 l=1,kl
            m1 = mfaru(iptr) - 1
            bkm = -ykmu(2,iptr)
            bkk = bkk + bkm
            jbp(ib) = m1
            bp(ib) = -bkm
            ib = ib + 1
            iptr = iptr + 1
 1700    continue
C
C        DIAGONAL TERMS FOR B-PRIME MATRIX
C
         jbp(ib) = k1
         bp(ib) = bkk
         ib = ib+1
 1850 continue

C     SET LAST ELEMENT OF POINTER ARRAYS

      ipbp(nbus) = ib
C
      if (idebug .gt. 1) then
         write(dbug,9530) (i,ipbp(i),i=1,nbus)
 9530    format(' IPBP ARRAY AND B-PRIME MATRIX',/,(1x,2i10))
         k = ib-1
         write(dbug,9550) (i,jbp(i),bp(i),i=1,k)
 9550    format(1x,2i10,e15.5)
      endif
C
C     FACTOR B-PRIME MATRIX
C
      call sfctr (iq, ipbp, bp, jbp, ipfbp, fbp, jfbp, dgbp, rpad1)
      k = ipfbp(nbus)
C
      if (idebug .gt. 1) then
         write(dbug,9580) (i,ipfbp(i),i=1,nbus)
 9580    format(' IPFBP ARRAY AFTER FACTORING B-PRIME',/,(1x,2i10))
         write(dbug,9550) (i,jfbp(i),fbp(i),i=1,k)
      endif
C
      return
      end


MODULE PIP_MOD  !Point-In-Polygon Module

!  The Point-in-Polygon Module contains one function, inpoly, which determines
!   if a point is inside or outside an irregularly shaped polygon using the
!   'crossings method', a 'point-in-polygon' technique.
!
!  Created by:            Zachary Schlag
!  Created on:            07 May 2007
!  Last Modified on:      11 Aug 2008

IMPLICIT NONE
PUBLIC

CONTAINS

  !Function inpoly returns .TRUE. if the point (x,y) lies within
  !  the polygon defined by the points in the variable e(n,2)
  !  It uses the point-in-polygon approach, shooting a ray out to the
  !  right of the point along the point's x coordinate, if an odd number
  !  of boundaries are crossed then the point is in the polygon.
  !The variable onin, is an optional variable used to designate whether
  !  a point on a boundary line is considered as in the polygon or out
  !  if the variable is not included in the function call, the function
  !  defaults to on a line being in the polygon
  LOGICAL FUNCTION inpoly(x,y,n,e,onin)
  !Input Variables
  INTEGER, INTENT(in) :: n                  ! number of edge points in polygon
  LOGICAL, INTENT(in), OPTIONAL :: onin     ! define polygon edge as in or out
  DOUBLE PRECISION, INTENT(in) :: x,y, &    ! particle x & y location
                                  e(n,2)    ! polygon edge coordinates

  !Additional Variables
  INTEGER :: i,j,hilo(n),crossed
  LOGICAL :: on,first,onout
  DOUBLE PRECISION :: m,b,ix

  if( present(onin) )then       !if the variable onin is present
    onout=.not.onin             !set onout to the opposite of onin
  else
    onout=.false.               !if onin is not present, default onout to false
  endif

  inpoly=.true.
  crossed=0

  !cycle through all edge points, determine if any are on the ray
  hilo=0        !initialize hilo to 0
  on=.false.    !initialize on to false, to indicate no edge points on the ray
  do i=1,n
    if( e(i,2) > y ) hilo(i)=1                  !if above ray, set hilo to  1
    if( e(i,2) < y ) hilo(i)=-1                 !if below ray, set hilo to -1
    if( e(i,2) == y .and. e(i,1)>x) on=.true.   !if on ray, set on true
    if( e(i,1)==x .and. e(i,2)==y)then          !if edge point on point:
      if(onout)inpoly=.false.                   ! if on means out inpoly=false
      return                                    ! return from function
    endif
  enddo

  !If any of the edge points are on the ray:
  if(on)then

    !initialize first to true in case the 'first' boundary point is on the ray
    first=.true.

    !initialize i to 1, used to iterate through boundary points
    i=1

    do
      if(i>n)exit                           !if all boundaries checked, exit
      if(hilo(i)==0 .and. e(i,1)>x)then     !if on ray:

        if(first)then                       !if first point:
          i=i+1                             !  increment i
          cycle                             !  and move on to next point
        endif

        !if the previous boundary point shares the point's x coordinate, but
        !  was not on the ray, then the boundary crossed the point:
        if(hilo(i-1)==0)then
          if(onout)inpoly=.false.           !if on means out set inpoly false
          return                            !return from the function
        endif

        !initialize j to 1, used to iterate through boundary points until
        !  the next boundary point is found which does not lie on the ray.
        !  if it iterates past the last boundary point, it cycles back to
        !  the beginning
        j=1
        do
          if((i+j)==(n+1))j=2-i     !if the end is reached, cycle to start
          if(hilo(i+j)/=0)exit      !if the boundary point is not on ray, exit
          !if the next boundary point not on the ray and shares the point's x
          !  coordinate, then the boundary crossed the point:
          if(e(i+j,1)<x)then
            if(onout)inpoly=.false.         !if on means out set inpoly false
            return                          !return from the function
          endif
          j=j+1     !increment j to check next boundary point
        enddo

        !if the boundary points on the ray are inbetween the preceeding and
        !  following boundary points (i.e., one of the points is above the ray
        !  and the other is below the ray), then increment crossed to indicate
        !  that the ray has been crossed
        if( (hilo(i-1)+hilo(i+j))==0 )crossed=crossed+1

        !if j<0 then it has iterated past the last boundary point and cycled
        !  back to the beginning, therefore all the boundaries have been
        !  checked and the loop can be exited
        if( j<0 ) exit

        !if it hasn't passed the last boundary point, move to
        !  the next point not on the ray
        i=i+j
      endif
      first=.false. !if the point wasn't on the ray, set first to false
      i=i+1         !increment i to iterate to next boundary point
    enddo

  endif

  !Check if the ray crosses each boundary segment
  do i=1,n-1

    !if both boundary points are left of the point, cycle
    if(e(i,1)<=x .and. e(i+1,1)<=x)cycle

    !if both boundary points are below the point, cycle
    if(e(i,2)<=y .and. e(i+1,2)<=y)cycle

    !if both boundary points are above the point, cycle
    if(e(i,2)>=y .and. e(i+1,2)>=y)cycle

    !if both boundary points are to the right of the point, increment crossed
    !  and cycle (if they are not both above or both below, but are both
    !  right of, then it has to cross)
    if(e(i,1)> x .and. e(i+1,1)> x)then
      crossed=crossed+1
      cycle
    endif

    !if it reaches the following code then one boundary point is above, one is
    !  below, and one is to the right of the point, while the other is left of
    !  the point therefore it may or may not cross the ray, so the slope and
    !  intercept must be calculated, then the intersection point of the ray
    !  with the boundary line must be calculated using the y coordinate of the
    !  point:

    m=  (e(i+1,2)-e(i,2))/(e(i+1,1)-e(i,1)) !slope
    b=  e(i,2)-m*e(i,1)                     !intercept
    ix= (y-b)/m                             !ix = intersection point

    if(ix==x)then                           !if x is on the intersection point:
      if(onout)inpoly=.false.               ! if on means out set inpoly false
      return                                ! return from the function
    endif

    !if x intersect is to the right of the point, then ray crosses boundary
    !  line, therefore increment the variable crossed
    if(ix>x)crossed=crossed+1
  enddo

  !If the ray crosses an even # of times, then the point is not in the polygon
  if( mod(crossed,2)==0 )inpoly=.false.

  RETURN
  END FUNCTION inpoly

END MODULE PIP_MOD