subroutine MakeGradientDH(cilm, lmax, theta_grid, phi_grid, n, sampling, &
                          lmax_calc, extend, exitstatus)
!------------------------------------------------------------------------------
!
!   Given the spherical harmonic coefficients CILM of a scalar function defined
!   on the sphere, this subroutine will compute the horizontal gradient of the
!   function, and return 2D Driscol and Healy sampled grids for the theta and
!   phi vector components. The gradient is given by the formula:
!
!       Grad F = 1/r dF/theta theta-hat + 1/(r sin theta) dF/dphi phi-hat
!
!   where theta is colatitude and phi is longitude. The radius r is taken from
!   the degree zero coefficient of the function CILM(1,1,1).
!
!   The output grids contain N samples in latitude and longitude by default,
!   but if the optional parameter SAMPLING is set to 2, the grids will contain
!   N samples in latitude and 2N samples in longitude. When SAMPLING = 1, the
!   output grids contain N samples in latitude from 90 to -90 + interval and N
!   samples in longitude from 0 to 360-2*interval, where N=2*(LMAX+1) and
!   interval=180/N. When SAMPLING = 2, the grids are equally spaced in degrees
!   latitude and longitude with dimension (N x 2N). If the optional parameter
!   EXTEND is set to 1, the output grids will contain an extra column
!   corresponding to 360 E and an extra row corresponding to 90 S, which
!   increases each of the dimensions of the grid by one.
!
!   This routine assumes that the spherical harmonic coefficients are
!   4-pi normalized and exclude the Condon-Shortley phase factor.
!
!   Calling Parameters
!
!       IN
!           cilm        Spherical harmonic coefficients of the scalar function.
!           lmax        The maximum spherical harmonic degree of the function,
!                       used to determine the number of samples N.
!
!       IN, OPTIONAL
!           sampling    (1) The output grids are N by N (default).
!                       (2) The output grids are N by 2N.
!           lmax_calc   The maximum spherical harmonic degree to evaluate
!                       the coefficients up to.
!           extend      If 1, return a grid that contains an additional column
!                       and row corresponding to 360 E longitude and 90 S
!                       latitude, respectively.
!
!       OUT
!           theta_grid  Gridded expansaion of the theta component of the
!                       gradient.
!           phi_grid    Gridded expansaion of the phi component of the
!                       gradient.
!           N           Number of samples in latitude. Number of samples in
!                       longitude is N when sampling is 1 (default), and is 2N
!                       when sampling is 2.
!
!       OUT, OPTIONAL
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!       1.  If lmax is greater than the the maximum spherical harmonic
!           degree of the input coefficients, then the coefficients will be
!           zero padded.
!       2.  Latitude is geocentric latitude.
!
!   Copyright (c) 2021, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use FFTW3
    use ftypes
    use, intrinsic :: iso_c_binding

    implicit none

    real(dp), intent(in) :: cilm(:,:,:)
    real(dp), intent(out) :: theta_grid(:,:), phi_grid(:,:)
    integer(int32), intent(in) :: lmax
    integer(int32), intent(out) :: n
    integer(int32), intent(in), optional :: sampling, lmax_calc, extend
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: l, m, i, l1, m1, lmax_comp, i_eq, i_s, astat(4), nlong, &
                      nlat_out, nlong_out, extend_grid
    real(dp) :: grid(4*lmax+4), pi, theta, scalef, rescalem, u, p, dpl, pmm, &
                pm1, pm2, z, tempr, lat, coeft0, coefts0, coefp0, &
                coefps0, r
    complex(dp) :: coef(2*lmax+3), coeft(2*lmax+3), coefts(2*lmax+3), &
                   coefp(2*lmax+3), coefps(2*lmax+3), tempc
    type(C_PTR) :: plan
    real(dp), save, allocatable :: ff1(:,:), ff2(:,:), sqr(:)
    integer(int8), save, allocatable :: fsymsign(:,:)
    integer(int32), save :: lmax_old = 0

!$OMP   threadprivate(ff1, ff2, sqr, fsymsign, lmax_old)

    if (present(exitstatus)) exitstatus = 0

    n = 2 * lmax + 2

    if (present(sampling)) then
        if (sampling == 1) then
            nlong = n
        else if (sampling == 2) then
            nlong = 2 * n
        else
            print*, "Error --- MakeGradientDH"
            print*, "Optional parameter SAMPLING must be 1 (N by N) " // &
                    "or 2 (N by 2N)."
            print*, "Input value is ", sampling
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        nlong = n
    end if

    if (present(extend)) then
        if (extend == 0) then
            extend_grid = 0
            nlat_out = n
            nlong_out = nlong
        else if (extend == 1) then
            extend_grid = 1
            nlat_out = n + 1
            nlong_out = nlong + 1
        else
            print*, "Error --- MakeGradientDH"
            print*, "Optional parameter EXTEND must be 0 or 1."
            print*, "Input value is ", extend
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if
        end if
    else
        extend_grid = 0
        nlat_out = n
        nlong_out = nlong
    end if

    if (size(cilm(:,1,1)) < 2) then
        print*, "Error --- MakeGradientDH"
        print*, "CILM must be dimensioned as (2, *, *)."
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (size(theta_grid(:,1)) < nlat_out .or. size(theta_grid(1,:)) < &
        nlong_out .or. size(phi_grid(:,1)) < nlat_out .or. &
        size(phi_grid(1,:)) < nlong_out) then
        print*, "Error --- MakeGradientDH"
        print*, "THETA_GRID and PHI_GRID " // &
                "must be dimensioned as: ", nlat_out, nlong_out
        print*, "Input dimensions are ", &
                size(theta_grid(:,1)), size(theta_grid(1,:)), &
                size(phi_grid(:,1)), size(phi_grid(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0_dp)

    scalef = 1.0e-280_dp

    if (present(lmax_calc)) then
        if (lmax_calc > lmax) then
            print*, "Error --- MakeGradientDH"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1, &
                            lmax_calc)

        end if

    else
        lmax_comp = min(lmax, size(cilm(1,1,:))-1, size(cilm(1,:,1))-1)

    end if

    r = cilm(1,1,1)  ! set the radius equal to the degree 0 term of the
                     ! function.
    !--------------------------------------------------------------------------
    !
    !   Calculate recursion constants used in computing Legendre functions.
    !
    !--------------------------------------------------------------------------
    if (lmax_comp /= lmax_old) then

        if (allocated (sqr)) deallocate (sqr)
        if (allocated (ff1)) deallocate (ff1)
        if (allocated (ff2)) deallocate (ff2)
        if (allocated (fsymsign)) deallocate (fsymsign)

        allocate (sqr(2*lmax_comp+1), stat=astat(1))
        allocate (ff1(lmax_comp+1,lmax_comp+1), stat=astat(2))
        allocate (ff2(lmax_comp+1,lmax_comp+1), stat=astat(3))
        allocate (fsymsign(lmax_comp+1,lmax_comp+1), stat=astat(4))

        if (sum(astat(1:4)) /= 0) then
            print*, "Error --- MakeGradientDH"
            print*, "Problem allocating arrays SQR, FF1, FF2, or FSYMSIGN", &
                    astat(1), astat(2), astat(3), astat(4)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if

        end if

        !----------------------------------------------------------------------
        !
        !   Calculate signs used for symmetry of Legendre functions about
        !   equator. For the first derivative in theta, these signs are
        !   reversed.
        !
        !----------------------------------------------------------------------
        do l = 0, lmax_comp, 1
            do m = 0, l, 1
                if (mod(l-m,2) == 0) then
                    fsymsign(l+1,m+1) = 1

                else
                    fsymsign(l+1,m+1) = -1

                end if

            end do

        end do

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l = 1, 2*lmax_comp+1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l as a
        !   different recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m)
        !   is assumed to be zero.
        !
        !----------------------------------------------------------------------
        if (lmax_comp /= 0) then
            ff1(2,1) = sqr(3)
            ff2(2,1) = 0.0_dp
        end if

        do l = 2, lmax_comp, 1
            ff1(l+1,1) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
            ff2(l+1,1) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

            do m = 1, l-2, 1
                ff1(l+1,m+1) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                ff2(l+1,m+1) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                               / sqr(2*l-3) / sqr(l+m) / sqr(l-m)
            end do

            ff1(l+1,l) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
            ff2(l+1,l) = 0.0_dp

        end do

        lmax_old = lmax_comp

    end if

    !--------------------------------------------------------------------------
    !
    !   Create generic plan for grid.
    !
    !--------------------------------------------------------------------------
    plan = fftw_plan_dft_c2r_1d(nlong, coef(1:nlong/2+1), grid(1:nlong), &
                                FFTW_MEASURE)

    !--------------------------------------------------------------------------
    !
    !   Determine Clms one l at a time by intergrating over latitude.
    !
    !--------------------------------------------------------------------------
    i_eq = n / 2 + 1  ! Index correspondong to zero latitude

    ! First do equator
    theta = pi / 2.0_dp
    z = 0.0_dp
    u = 1.0_dp

    coeft(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coeft0 = 0.0_dp

    coefp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
    coefp0 = 0.0_dp

    pm2 = 1.0_dp

    ! derivative of l=0 term is 0, so no need to calculate this

    if (lmax_comp /= 0) then    ! l = 1
        pm1 = 0.0_dp
        dpl = ff1(2,1)
        coeft0 = coeft0 + cilm(1,2,1) * dpl

    end if

    do l = 2, lmax_comp, 1
        l1 = l + 1
        p = - ff2(l1,1) * pm2

        dpl = l * (sqr(2*l+1) / sqr(2*l-1) * pm1)
        coeft0 = coeft0 + cilm(1,l1,1) * dpl

        pm2 = pm1
        pm1 = p

    end do

    pmm = sqr(2) * scalef

    rescalem = 1.0_dp / scalef

    do m = 1, lmax_comp-1, 1
        m1 = m + 1

        pmm = pmm * sqr(2*m+1) / sqr(2*m)
        pm2 = pmm

        coefp(m1) = coefp(m1) + cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) &
                                * pm2 * m

        pm1 = 0.0_dp

        dpl = (sqr(2*m+3) * pmm)
        coeft(m1) = coeft(m1) + cmplx(cilm(1,m1+1,m1), &
                                - cilm(2,m1+1,m1), dp) * dpl

        do l = m+2, lmax_comp, 1
            l1 = l + 1
            p = - ff2(l1,m1) * pm2

            coefp(m1) = coefp(m1) + cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) &
                                    * p * m

            dpl = ( sqr(2*l+1) * sqr(l-m) * sqr(l+m) / sqr(2*l-1) * pm1)
            coeft(m1) = coeft(m1) + cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) &
                                    * dpl

            pm2 = pm1
            pm1 = p

        end do

        coefp(m1) = coefp(m1) * rescalem
        coeft(m1) = coeft(m1) * rescalem

    end do

    if (lmax_comp /= 0) then

        pmm = pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem

        coefp(lmax_comp+1) = coefp(lmax_comp+1) &
                            + cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                            cilm(1,lmax_comp+1,lmax_comp+1), dp) &
                            * pmm * lmax_comp

        dpl = -lmax_comp * z * pmm / u**2
        coeft(lmax_comp+1) = coeft(lmax_comp+1) + &
                            cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) &
                            * dpl

    end if

    coef(1) = cmplx(coeft0, 0.0_dp, dp)
    coef(2:lmax+1) = coeft(2:lmax+1) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    theta_grid(i_eq,1:nlong) = -sin(theta) * grid(1:nlong) / r

    coef(1) = cmplx(coefp0, 0.0_dp, dp)
    coef(2:lmax+1) = coefp(2:lmax+1) / 2.0_dp

    if (present(sampling)) then
        if (sampling == 2) then
            coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
        end if
    end if

    call fftw_execute_dft_c2r(plan, coef, grid)
    phi_grid(i_eq,1:nlong) = grid(1:nlong) / r / sin(theta)

    do i=1, i_eq-1, 1

        i_s = 2 * i_eq - i

        theta = pi * dble(i-1) / dble(n)
        z = cos(theta)
        u = sqrt( (1.0_dp-z) * (1.0_dp+z) )

        lat = pi / 2.0_dp - theta

        coeft(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coeft0 = 0.0_dp
        coefts(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefts0 = 0.0_dp

        coefp(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefp0 = 0.0_dp
        coefps(1:lmax+2) = cmplx(0.0_dp, 0.0_dp, dp)
        coefps0 = 0.0_dp

        pm2 = 1.0_dp

        ! derivative of l=0 term is 0, so no need to calculate this

        if (lmax_comp /= 0) then    ! l = 1
            pm1 = ff1(2,1) * z

            dpl = ff1(2,1)
            tempr = cilm(1,2,1) * dpl
            coeft0 = coeft0 + tempr
            coefts0 = coefts0 + tempr   ! reverse fsymsign

        end if

        do l = 2, lmax_comp, 1
            l1 = l + 1
            p = ff1(l1,1) * z * pm1 - ff2(l1,1) * pm2
            dpl = l * ( sqr(2*l+1) / sqr(2*l-1) * pm1 - z * p ) / u**2
            tempr = cilm(1,l1,1) * dpl
            coeft0 = coeft0 + tempr
            coefts0 = coefts0 - tempr * fsymsign(l1,1)  ! reverse fsymsign

            pm2 = pm1
            pm1 = p

        end do

        pmm = sqr(2) * scalef

        rescalem = 1.0_dp / scalef

        do m = 1, lmax_comp-1, 1

            m1 = m + 1
            rescalem = rescalem * u

            pmm = pmm * sqr(2*m+1) / sqr(2*m)
            pm2 = pmm

            ! (m,m)
            tempc = cmplx(cilm(2,m1,m1), cilm(1,m1,m1), dp) * pm2 * m
            coefp(m1) = coefp(m1) + tempc
            coefps(m1) = coefps(m1) + tempc
            ! fsymsign = 1

            dpl = -m * z * pm2 / u**2
            tempc = cmplx(cilm(1,m1,m1), - cilm(2,m1,m1), dp) * dpl  ! (m,m)
            coeft(m1) = coeft(m1) + tempc
            coefts(m1) = coefts(m1) - tempc ! reverse fsymsign

            pm1 = z * ff1(m1+1,m1) * pm2

            tempc = cmplx(cilm(2,m1+1,m1), cilm(1,m1+1,m1), dp) * pm1 &
                    * m ! (m+1,m)
            coefp(m1) = coefp(m1) + tempc
            coefps(m1) = coefps(m1) - tempc
            ! fsymsign = -1

            ! (m+1,m)
            dpl = ( sqr(2*m+3) * pmm - z * (m+1) * pm1) / u**2
            tempc = cmplx(cilm(1,m1+1,m1), - cilm(2,m1+1,m1), dp) * dpl
            coeft(m1) = coeft(m1) + tempc
            coefts(m1) = coefts(m1) + tempc ! reverse fsymsign

            do l=m+2, lmax_comp, 1
                l1 = l + 1
                p = z * ff1(l1,m1) * pm1 - ff2(l1,m1) * pm2

                tempc = cmplx(cilm(2,l1,m1), cilm(1,l1,m1), dp) * p * m
                coefp(m1) = coefp(m1) + tempc
                coefps(m1) = coefps(m1) + tempc * fsymsign(l1,m1)

                dpl = ( sqr(2*l+1) * sqr(l-m) * sqr(l+m) / sqr(2*l-1) * pm1 &
                       - z * l * p) / u**2
                tempc = cmplx(cilm(1,l1,m1), - cilm(2,l1,m1), dp) * dpl
                coeft(m1) = coeft(m1) + tempc
                ! reverse fsymsign
                coefts(m1) = coefts(m1) - tempc * fsymsign(l1,m1)

                pm2 = pm1
                pm1 = p

            end do

            coeft(m1) = coeft(m1) * rescalem
            coefts(m1) = coefts(m1) * rescalem

            coefp(m1) = coefp(m1) * rescalem
            coefps(m1) = coefps(m1) * rescalem

        end do

        if (lmax_comp /= 0) then

            rescalem = rescalem * u

            pmm = pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem

            tempc = cmplx(cilm(2,lmax_comp+1,lmax_comp+1), &
                            cilm(1,lmax_comp+1,lmax_comp+1), dp) * pmm &
                            * lmax_comp
            coefp(lmax_comp+1) = coefp(lmax_comp+1) + tempc
            coefps(lmax_comp+1) = coefps(lmax_comp+1) + tempc
            ! fsymsign = 1

            dpl = -lmax_comp * z * pmm / u**2
            tempc = cmplx(cilm(1,lmax_comp+1,lmax_comp+1), &
                            - cilm(2,lmax_comp+1,lmax_comp+1), dp) * dpl
            coeft(lmax_comp+1) = coeft(lmax_comp+1) + tempc
            ! reverse fsymsign
            coefts(lmax_comp+1) = coefts(lmax_comp+1) - tempc

        end if

        if (i == 1) then
            ! These two derivatives are undefined at the pole
            theta_grid(1,1:nlong) = 0.0_dp
            phi_grid(1,1:nlong) = 0.0_dp

        else
            coef(1) = cmplx(coeft0, 0.0_dp, dp)
            coef(2:lmax+1) = coeft(2:lmax+1) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            theta_grid(i,1:nlong) = -sin(theta) * grid(1:nlong) / r

            coef(1) = cmplx(coefp0, 0.0_dp, dp)
            coef(2:lmax+1) = coefp(2:lmax+1) / 2.0_dp

            if (present(sampling)) then
                if (sampling == 2) then
                    coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                end if
            end if

            call fftw_execute_dft_c2r(plan, coef, grid)
            phi_grid(i,1:nlong) = grid(1:nlong) / r / sin(theta)

        end if

        ! don't compute value for south pole when extend = 0.
        if (.not. (i == 1 .and. extend_grid == 0) ) then

            if (i == 1) then
                ! These two derivatives are undefined at the pole
                theta_grid(i_s,1:nlong) = 0.0_dp
                phi_grid(i_s,1:nlong) = 0.0_dp

            else
                coef(1) = cmplx(coefts0, 0.0_dp, dp)
                coef(2:lmax+1) = coefts(2:lmax+1) / 2.0_dp

                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                theta_grid(i_s,1:nlong) = -sin(theta) * grid(1:nlong) / r

                coef(1) = cmplx(coefps0, 0.0_dp, dp)
                coef(2:lmax+1) = coefps(2:lmax+1) / 2.0_dp
                if (present(sampling)) then
                    if (sampling == 2) then
                        coef(lmax+2:2*lmax+3) = cmplx(0.0_dp, 0.0_dp, dp)
                    end if
                end if

                call fftw_execute_dft_c2r(plan, coef, grid)
                phi_grid(i_s,1:nlong) = grid(1:nlong) / r / sin(theta)

            end if

        end if

    end do

    call fftw_destroy_plan(plan)

    if (extend_grid == 1) then
        theta_grid(1:nlat_out, nlong_out) = theta_grid(1:nlat_out, 1)
        phi_grid(1:nlat_out, nlong_out) = phi_grid(1:nlat_out, 1)

    end if

end subroutine MakeGradientDH


!*****************************************************************************************
!>
!  Refactored SLATEC/EISPACK routines for computing eigenvalues and eigenvectors.

    module eispack_module

    use kind_module, only: wp

    implicit none

    private

    public :: compute_eigenvalues_and_eigenvectors

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!***PURPOSE  Balance a real general matrix and isolate eigenvalues
!            whenever possible.
!***KEYWORDS  EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure BALANCE,
!     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
!     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
!
!     This subroutine balances a REAL matrix and isolates
!     eigenvalues whenever possible.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameter, A, as declared in the calling program
!          dimension statement.  NM is an INTEGER variable.
!
!        N is the order of the matrix A.  N is an INTEGER variable.
!          N must be less than or equal to NM.
!
!        A contains the input matrix to be balanced.  A is a
!          two-dimensional REAL array, dimensioned A(NM,N).
!
!     On OUTPUT
!
!        A contains the balanced matrix.
!
!        LOW and IGH are two INTEGER variables such that A(I,J)
!          is equal to zero if
!           (1) I is greater than J and
!           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
!
!        SCALE contains information determining the permutations and
!          scaling factors used.  SCALE is a one-dimensional REAL array,
!          dimensioned SCALE(N).
!
!     Suppose that the principal submatrix in rows LOW through IGH
!     has been balanced, that P(J) denotes the index interchanged
!     with J during the permutation step, and that the elements
!     of the diagonal matrix used are denoted by D(I,J).  Then
!        SCALE(J) = P(J),    for J = 1,...,LOW-1
!                 = D(J,J),      J = LOW,...,IGH
!                 = P(J)         J = IGH+1,...,N.
!     The order in which the interchanges are made is N to IGH+1,
!     then 1 TO LOW-1.
!
!     Note that 1 is returned for IGH if IGH is zero formally.
!
!     The ALGOL procedure EXC contained in BALANCE appears in
!     BALANC  in line.  (Note that the ALGOL roles of identifiers
!     K,L have been reversed.)
!
!     Questions and comments should be directed to B. S. Garbow,
!     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine balanc(Nm, n, a, Low, Igh, Scale)
    implicit none

    integer i, j, k, l, m, n, jj, Nm, Igh, Low, iexc, igo, igo1, igo2
    real(wp) a(Nm, *), Scale(*)
    real(wp) c, f, g, r, s, b2, radix
    logical noconv

    radix = 16
    b2 = radix*radix
    k = 1
    l = n
    igo = 1
    igo1 = 0
    igo2 = 1
    ! IN-LINE PROCEDURE FOR ROW AND
    ! COLUMN EXCHANGE
    do while (igo2 == 1)
       igo2 = 0
       if (igo1 == 1) then
          Scale(m) = j
          if (j /= m) then
             do i = 1, l
                f = a(i, j)
                a(i, j) = a(i, m)
                a(i, m) = f
             enddo
             do i = k, n
                f = a(j, i)
                a(j, i) = a(m, i)
                a(m, i) = f
             enddo
          endif
          if (iexc == 2) then
             ! SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
             ! AND PUSH THEM LEFT
             k = k + 1
             igo = 0
          else
             ! SEARCH FOR ROWS ISOLATING AN EIGENVALUE
             ! AND PUSH THEM DOWN
             if (l == 1) then
                Low = k
                Igh = l
                return
             end if
             l = l - 1
          endif
       end if
       ! FOR J=L STEP -1 UNTIL 1 DO --
       igo1 = 1
       if (igo == 1) then
          do jj = 1, l
             igo = 1
             j = l + 1 - jj
             do i = 1, l
                if (i /= j) then
                   if (a(j, i) /= 0.0_wp) then
                      igo = 0
                      exit
                   end if
                endif
             enddo
             if (igo == 0) cycle
             m = l
             iexc = 1
             igo2 = 1
             exit
          enddo
          if (igo2 == 1) cycle
       end if
       do j = k, l
          igo = 1
          do i = k, l
             if (i /= j) then
                if (a(i, j) /= 0.0_wp) then
                   igo = 0
                   exit
                end if
             endif
          enddo
          if (igo == 0) cycle
          m = k
          iexc = 2
          igo2 = 1
          exit
       enddo
       if (igo2 == 1) cycle
    end do
    ! NOW BALANCE THE SUBMATRIX IN ROWS K TO L
    do i = k, l
       Scale(i) = 1.0_wp
    enddo
    ! ITERATIVE LOOP FOR NORM REDUCTION
    noconv = .true.
    do while (noconv)
       noconv = .false.
       do i = k, l
          c = 0.0_wp
          r = 0.0_wp
          do j = k, l
             if (j /= i) then
                c = c + abs(a(j, i))
                r = r + abs(a(i, j))
             endif
          enddo
          ! GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW
          if (c /= 0.0_wp .and. r /= 0.0_wp) then
             g = r/radix
             f = 1.0_wp
             s = c + r

             do while (c < g)
                f = f*radix
                c = c*b2
             end do
             g = r*radix
             do while (c >= g)
                f = f/radix
                c = c/b2
             end do
             ! NOW BALANCE
             if ((c + r)/f < 0.95_wp*s) then
                g = 1.0_wp/f
                Scale(i) = Scale(i)*f
                noconv = .true.
                do j = k, n
                   a(i, j) = a(i, j)*g
                enddo
                do j = 1, l
                   a(j, i) = a(j, i)*f
                enddo
             endif
          endif
       enddo
    end do
    Low = k
    Igh = l
 end subroutine balanc

!*****************************************************************************************
!>
!***PURPOSE  Form the eigenvectors of a real general matrix from the
!            eigenvectors of matrix output from BALANC.
!***KEYWORDS  EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure BALBAK,
!     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
!     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
!
!     This subroutine forms the eigenvectors of a REAL GENERAL
!     matrix by back transforming those of the corresponding
!     balanced matrix determined by  BALANC.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameter, Z, as declared in the calling program
!          dimension statement.  NM is an INTEGER variable.
!
!        N is the number of components of the vectors in matrix Z.
!          N is an INTEGER variable.  N must be less than or equal
!          to NM.
!
!        LOW and IGH are INTEGER variables determined by  BALANC.
!
!        SCALE contains information determining the permutations and
!          scaling factors used by  BALANC.  SCALE is a one-dimensional
!          REAL array, dimensioned SCALE(N).
!
!        M is the number of columns of Z to be back transformed.
!          M is an INTEGER variable.
!
!        Z contains the real and imaginary parts of the eigen-
!          vectors to be back transformed in its first M columns.
!          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
!
!     On OUTPUT
!
!        Z contains the real and imaginary parts of the
!          transformed eigenvectors in its first M columns.
!
!     Questions and comments should be directed to B. S. Garbow,
!     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine balbak(Nm, n, Low, Igh, Scale, m, z)
    implicit none

    integer i, j, k, m, n, ii, Nm, Igh, Low
    real(wp) Scale(*), z(Nm, *)
    real(wp) s

    if (m /= 0) then
       if (Igh /= Low) then

          do i = Low, Igh
             s = Scale(i)
             ! LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
             ! IF THE FOREGOING STATEMENT IS REPLACED BY
             ! S=1.0_wp/SCALE(I).
             do j = 1, m
                z(i, j) = z(i, j)*s
             enddo

          enddo
       endif
       ! FOR I=LOW-1 STEP -1 UNTIL 1,
       ! IGH+1 STEP 1 UNTIL N DO --
       do ii = 1, n
          i = ii
          if (i < Low .or. i > Igh) then
             if (i < Low) i = Low - ii
             k = Scale(i)
             if (k /= i) then

                do j = 1, m
                   s = z(i, j)
                   z(i, j) = z(k, j)
                   z(k, j) = s
                enddo
             endif
          endif

       enddo
    endif

 end subroutine balbak

!*****************************************************************************************
!>
!***PURPOSE  Compute the complex quotient of two complex numbers.
!***AUTHOR  (UNKNOWN)
!***DESCRIPTION
!
!     Complex division, (CR,CI) = (AR,AI)/(BR,BI)
!
!***SEE ALSO  EISDOC
!***REVISION HISTORY  (YYMMDD)
!   811101  DATE WRITTEN
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900402  Added TYPE section.  (WRB)

 subroutine cdiv(Ar, Ai, Br, Bi, Cr, Ci)

    implicit none

    real(wp) Ar, Ai, Br, Bi, Cr, Ci

    real(wp) s, ars, ais, brs, bis

    s = abs(Br) + abs(Bi)
    ars = Ar/s
    ais = Ai/s
    brs = Br/s
    bis = Bi/s
    s = brs**2 + bis**2
    Cr = (ars*brs + ais*bis)/s
    Ci = (ais*brs - ars*bis)/s

 end subroutine cdiv

!*****************************************************************************************
!>
!***PURPOSE  Reduce a real general matrix to upper Hessenberg form
!            using stabilized elementary similarity transformations.
!***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure ELMHES,
!     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
!
!     Given a REAL GENERAL matrix, this subroutine
!     reduces a submatrix situated in rows and columns
!     LOW through IGH to upper Hessenberg form by
!     stabilized elementary similarity transformations.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameter, A, as declared in the calling program
!          dimension statement.  NM is an INTEGER variable.
!
!        N is the order of the matrix, A.  N is an INTEGER variable.
!          N must be less than or equal to NM.
!
!        LOW and IGH are two INTEGER variables determined by the
!          balancing subroutine  BALANC.  If  BALANC  has not been
!          used, set LOW=1 and IGH equal to the order of the matrix, N.
!
!        A contains the input matrix.  A is a two-dimensional REAL
!          array, dimensioned A(NM,N).
!
!     On OUTPUT
!
!        A contains the upper Hessenberg matrix.  The multipliers which
!          were used in the reduction are stored in the remaining
!          triangle under the Hessenberg matrix.
!
!        INTV contains information on the rows and columns interchanged
!          in the reduction.  Only elements LOW through IGH are used.
!          INTV is a one-dimensional INTEGER array, dimensioned INTV(IGH).
!
!     Questions and comments should be directed to B. S. Garbow,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine elmhes(Nm, n, Low, Igh, a, Intv)
    implicit none

    integer i, j, m, n, la, Nm, Igh, kp1, Low, mm1, mp1
    real(wp) a(Nm, *)
    real(wp) x, y
    integer Intv(*)

    la = Igh - 1
    kp1 = Low + 1
    if (la >= kp1) then

       do m = kp1, la
          mm1 = m - 1
          x = 0.0_wp
          i = m

          do j = m, Igh
             if (abs(a(j, mm1)) > abs(x)) then
                x = a(j, mm1)
                i = j
             endif
          enddo

          Intv(m) = i
          if (i /= m) then
             ! INTERCHANGE ROWS AND COLUMNS OF A
             do j = mm1, n
                y = a(i, j)
                a(i, j) = a(m, j)
                a(m, j) = y
             enddo

             do j = 1, Igh
                y = a(j, i)
                a(j, i) = a(j, m)
                a(j, m) = y
             enddo
          endif
          ! END INTERCHANGE
          if (x /= 0.0_wp) then
             mp1 = m + 1

             do i = mp1, Igh
                y = a(i, mm1)
                if (y /= 0.0_wp) then
                   y = y/x
                   a(i, mm1) = y

                   do j = m, n
                      a(i, j) = a(i, j) - y*a(m, j)
                   enddo

                   do j = 1, Igh
                      a(j, m) = a(j, m) + y*a(j, i)
                   enddo
                endif

             enddo
          endif

       enddo
    endif

 end subroutine elmhes

!*****************************************************************************************
!>
!***PURPOSE  Accumulates the stabilized elementary similarity
!            transformations used in the reduction of a real general
!            matrix to upper Hessenberg form by ELMHES.
!***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure ELMTRANS,
!     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
!
!     This subroutine accumulates the stabilized elementary
!     similarity transformations used in the reduction of a
!     REAL GENERAL matrix to upper Hessenberg form by  ELMHES.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameters, A and Z, as declared in the calling
!          program dimension statement.  NM is an INTEGER variable.
!
!        N is the order of the matrix A.  N is an INTEGER variable.
!          N must be less than or equal to NM.
!
!        LOW and IGH are two INTEGER variables determined by the
!          balancing subroutine  BALANC.  If  BALANC  has not been
!          used, set LOW=1 and IGH equal to the order of the matrix, N.
!
!        A contains the multipliers which were used in the reduction
!          by  ELMHES  in its lower triangle below the subdiagonal.
!          A is a two-dimensional REAL array, dimensioned A(NM,IGH).
!
!        INT contains information on the rows and columns interchanged
!          in the reduction by  ELMHES.  Only elements LOW through IGH
!          are used.  INT is a one-dimensional INTEGER array,
!          dimensioned INT(IGH).
!
!     On OUTPUT
!
!        Z contains the transformation matrix produced in the reduction
!          by  ELMHES.  Z is a two-dimensional REAL array, dimensioned
!          Z(NM,N).
!
!     Questions and comments should be directed to B. S. Garbow,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine eltran(Nm, n, Low, Igh, a, Int, z)
    implicit none

    integer i, j, n, kl, mm, mp, Nm, Igh, Low, mp1
    real(wp) a(Nm, *), z(Nm, *)
    integer Int(*)

    do i = 1, n
       do j = 1, n
          z(i, j) = 0.0_wp
       enddo
       z(i, i) = 1.0_wp
    enddo

    kl = Igh - Low - 1
    if (kl >= 1) then
       ! for mp=igh-1 step -1 until low+1 do --
       do mm = 1, kl
          mp = Igh - mm
          mp1 = mp + 1
          do i = mp1, Igh
             z(i, mp) = a(i, mp - 1)
          enddo
          i = Int(mp)
          if (i /= mp) then

             do j = mp, Igh
                z(mp, j) = z(i, j)
                z(i, j) = 0.0_wp
             enddo
             z(i, mp) = 1.0_wp
          endif
       enddo
    endif

 end subroutine eltran

!*****************************************************************************************
!>
!***PURPOSE  Compute the eigenvalues of a real upper Hessenberg matrix
!            using the QR method.
!***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure HQR,
!     NUM. MATH. 14, 219-231(1970) by Martin, Peters, and Wilkinson.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
!
!     This subroutine finds the eigenvalues of a REAL
!     UPPER Hessenberg matrix by the QR method.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameter, H, as declared in the calling program
!          dimension statement.  NM is an INTEGER variable.
!
!        N is the order of the matrix H.  N is an INTEGER variable.
!          N must be less than or equal to NM.
!
!        LOW and IGH are two INTEGER variables determined by the
!          balancing subroutine  BALANC.  If  BALANC  has not been
!          used, set LOW=1 and IGH equal to the order of the matrix, N.
!
!        H contains the upper Hessenberg matrix.  Information about
!          the transformations used in the reduction to Hessenberg
!          form by  ELMHES  or  ORTHES, if performed, is stored
!          in the remaining triangle under the Hessenberg matrix.
!          H is a two-dimensional REAL array, dimensioned H(NM,N).
!
!     On OUTPUT
!
!        H has been destroyed.  Therefore, it must be saved before
!          calling  HQR  if subsequent calculation and back
!          transformation of eigenvectors is to be performed.
!
!        WR and WI contain the real and imaginary parts, respectively,
!          of the eigenvalues.  The eigenvalues are unordered except
!          that complex conjugate pairs of values appear consecutively
!          with the eigenvalue having the positive imaginary part first.
!          If an error exit is made, the eigenvalues should be correct
!          for indices IERR+1, IERR+2, ..., N.  WR and WI are one-
!          dimensional REAL arrays, dimensioned WR(N) and WI(N).
!
!        IERR is an INTEGER flag set to
!          Zero       for normal return,
!          J          if the J-th eigenvalue has not been
!                     determined after a total of 30*N iterations.
!                     The eigenvalues should be correct for indices
!                     IERR+1, IERR+2, ..., N.
!
!     Questions and comments should be directed to B. S. Garbow,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine hqr(Nm, n, Low, Igh, h, Wr, Wi, Ierr)
    implicit none

    integer i, j, k, l, m, n, en, ll, mm, na, Nm, Igh, &
       itn, its, Low, mp2, enm2, Ierr, gt
    real(wp) h(Nm, *), Wr(*), Wi(*)
    real(wp) p, q, r, s, t, w, x, y, zz, norm, s1, s2
    logical notlas

    gt = 0
    Ierr = 0
    norm = 0.0_wp
    k = 1
    ! STORE ROOTS ISOLATED BY BALANC
    ! AND COMPUTE MATRIX NORM
    do i = 1, n
       !
       do j = k, n
          norm = norm + abs(h(i, j))
       enddo
       !
       k = i
       if (i < Low .or. i > Igh) then
          Wr(i) = h(i, i)
          Wi(i) = 0.0_wp
       endif
    enddo

    en = Igh
    t = 0.0_wp
    itn = 30*n
    ! SEARCH FOR NEXT EIGENVALUES
    do while (en >= Low)
       gt = 0
       its = 0
       na = en - 1
       enm2 = na - 1
       ! LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
       ! FOR L=EN STEP -1 UNTIL LOW DO --
       do while (.true.)
          do ll = Low, en
             l = en + Low - ll
             if (l == Low) exit
             s = abs(h(l - 1, l - 1)) + abs(h(l, l))
             if (s == 0.0_wp) s = norm
             s2 = s + abs(h(l, l - 1))
             if (s2 == s) exit
          enddo
          ! FORM SHIFT
          x = h(en, en)
          if (l == en) then
             ! ONE ROOT FOUND
             Wr(en) = x + t
             Wi(en) = 0.0_wp
             en = na
             gt = 1
             exit
          else
             y = h(na, na)
             w = h(en, na)*h(na, en)
             if (l == na) exit
             if (itn == 0) then
                ! SET ERROR -- NO CONVERGENCE TO AN
                ! EIGENVALUE AFTER 30*N ITERATIONS
                Ierr = en
                return
             else
                if (its == 10 .or. its == 20) then
                   ! FORM EXCEPTIONAL SHIFT
                   t = t + x
                   do i = Low, en
                      h(i, i) = h(i, i) - x
                   enddo
                   s = abs(h(en, na)) + abs(h(na, enm2))
                   x = 0.75_wp*s
                   y = x
                   w = -0.4375_wp*s*s
                endif
                its = its + 1
                itn = itn - 1
                ! LOOK FOR TWO CONSECUTIVE SMALL
                ! SUB-DIAGONAL ELEMENTS.
                ! FOR M=EN-2 STEP -1 UNTIL L DO --
                do mm = l, enm2
                   m = enm2 + l - mm
                   zz = h(m, m)
                   r = x - zz
                   s = y - zz
                   p = (r*s - w)/h(m + 1, m) + h(m, m + 1)
                   q = h(m + 1, m + 1) - zz - r - s
                   r = h(m + 2, m + 1)
                   s = abs(p) + abs(q) + abs(r)
                   p = p/s
                   q = q/s
                   r = r/s
                   if (m == l) exit
                   s1 = abs(p)*(abs(h(m - 1, m - 1)) + abs(zz) + abs(h(m + 1, m + 1)))
                   s2 = s1 + abs(h(m, m - 1))*(abs(q) + abs(r))
                   if (s2 == s1) exit
                enddo
                mp2 = m + 2
                do i = mp2, en
                   h(i, i - 2) = 0.0_wp
                   if (i /= mp2) h(i, i - 3) = 0.0_wp
                enddo
                ! DOUBLE QR STEP INVOLVING ROWS L TO EN AND
                ! COLUMNS M TO EN
                do k = m, na
                   notlas = k /= na
                   if (k /= m) then
                      p = h(k, k - 1)
                      q = h(k + 1, k - 1)
                      r = 0.0_wp
                      if (notlas) r = h(k + 2, k - 1)
                      x = abs(p) + abs(q) + abs(r)
                      if (x == 0.0_wp) cycle
                      p = p/x
                      q = q/x
                      r = r/x
                   endif
                   s = sign(sqrt(p*p + q*q + r*r), p)
                   if (k == m) then
                      if (l /= m) h(k, k - 1) = -h(k, k - 1)
                   else
                      h(k, k - 1) = -s*x
                   endif
                   p = p + s
                   x = p/s
                   y = q/s
                   zz = r/s
                   q = q/p
                   r = r/p
                   ! ROW MODIFICATION
                   do j = k, en
                      p = h(k, j) + q*h(k + 1, j)
                      if (notlas) then
                         p = p + r*h(k + 2, j)
                         h(k + 2, j) = h(k + 2, j) - p*zz
                      endif
                      h(k + 1, j) = h(k + 1, j) - p*y
                      h(k, j) = h(k, j) - p*x
                   enddo
                   j = min(en, k + 3)
                   ! COLUMN MODIFICATION
                   do i = l, j
                      p = x*h(i, k) + y*h(i, k + 1)
                      if (notlas) then
                         p = p + zz*h(i, k + 2)
                         h(i, k + 2) = h(i, k + 2) - p*r
                      endif
                      h(i, k + 1) = h(i, k + 1) - p*q
                      h(i, k) = h(i, k) - p
                   enddo
                enddo
             endif
          endif
       enddo
       ! TWO ROOTS FOUND
       if (gt == 0) then
          p = (y - x)/2.0_wp
          q = p*p + w
          zz = sqrt(abs(q))
          x = x + t
          if (q < 0.0_wp) then
             ! COMPLEX PAIR
             Wr(na) = x + p
             Wr(en) = x + p
             Wi(na) = zz
             Wi(en) = -zz
          else
             ! REAL PAIR
             zz = p + sign(zz, p)
             Wr(na) = x + zz
             Wr(en) = Wr(na)
             if (zz /= 0.0_wp) Wr(en) = x - w/zz
             Wi(na) = 0.0_wp
             Wi(en) = 0.0_wp
          endif
          en = enm2
       end if
    enddo
 end subroutine hqr

!*****************************************************************************************
!>
!***PURPOSE  Compute the eigenvalues and eigenvectors of a real upper
!            Hessenberg matrix using QR method.
!***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
!***AUTHOR  Smith, B. T., et al.
!***DESCRIPTION
!
!     This subroutine is a translation of the ALGOL procedure HQR2,
!     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
!     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
!
!     This subroutine finds the eigenvalues and eigenvectors
!     of a REAL UPPER Hessenberg matrix by the QR method.  The
!     eigenvectors of a REAL GENERAL matrix can also be found
!     if  ELMHES  and  ELTRAN  or  ORTHES  and  ORTRAN  have
!     been used to reduce this general matrix to Hessenberg form
!     and to accumulate the similarity transformations.
!
!     On INPUT
!
!        NM must be set to the row dimension of the two-dimensional
!          array parameters, H and Z, as declared in the calling
!          program dimension statement.  NM is an INTEGER variable.
!
!        N is the order of the matrix H.  N is an INTEGER variable.
!          N must be less than or equal to NM.
!
!        LOW and IGH are two INTEGER variables determined by the
!          balancing subroutine  BALANC.  If  BALANC  has not been
!          used, set LOW=1 and IGH equal to the order of the matrix, N.
!
!        H contains the upper Hessenberg matrix.  H is a two-dimensional
!          REAL array, dimensioned H(NM,N).
!
!        Z contains the transformation matrix produced by  ELTRAN
!          after the reduction by  ELMHES, or by  ORTRAN  after the
!          reduction by  ORTHES, if performed.  If the eigenvectors
!          of the Hessenberg matrix are desired, Z must contain the
!          identity matrix.  Z is a two-dimensional REAL array,
!          dimensioned Z(NM,M).
!
!     On OUTPUT
!
!        H has been destroyed.
!
!        WR and WI contain the real and imaginary parts, respectively,
!          of the eigenvalues.  The eigenvalues are unordered except
!          that complex conjugate pairs of values appear consecutively
!          with the eigenvalue having the positive imaginary part first.
!          If an error exit is made, the eigenvalues should be correct
!          for indices IERR+1, IERR+2, ..., N.  WR and WI are one-
!          dimensional REAL arrays, dimensioned WR(N) and WI(N).
!
!        Z contains the real and imaginary parts of the eigenvectors.
!          If the J-th eigenvalue is real, the J-th column of Z
!          contains its eigenvector.  If the J-th eigenvalue is complex
!          with positive imaginary part, the J-th and (J+1)-th
!          columns of Z contain the real and imaginary parts of its
!          eigenvector.  The eigenvectors are unnormalized.  If an
!          error exit is made, none of the eigenvectors has been found.
!
!        IERR is an INTEGER flag set to
!          Zero       for normal return,
!          J          if the J-th eigenvalue has not been
!                     determined after a total of 30*N iterations.
!                     The eigenvalues should be correct for indices
!                     IERR+1, IERR+2, ..., N, but no eigenvectors are
!                     computed.
!
!     Calls CDIV for complex division.
!
!     Questions and comments should be directed to B. S. Garbow,
!     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
!     ------------------------------------------------------------------
!
!***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!                 system Routines - EISPACK Guide, Springer-Verlag,
!                 1976.
!***REVISION HISTORY  (YYMMDD)
!   760101  DATE WRITTEN
!   890531  Changed all specific intrinsics to generic.  (WRB)
!   890831  Modified array declarations.  (WRB)
!   890831  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)

 subroutine hqr2(Nm, n, Low, Igh, h, Wr, Wi, z, Ierr)
    implicit none

    integer i, j, k, l, m, n, en, ii, jj, ll, mm, na, Nm, &
       nn, gt
    integer Igh, itn, its, Low, mp2, enm2, Ierr
    real(wp) h(Nm, *), Wr(*), Wi(*), z(Nm, *)
    real(wp) p, q, r, s, t, w, x, y, ra, sa, vi, vr, zz, &
       norm, s1, s2
    logical notlas

    gt = 0
    Ierr = 0
    norm = 0.0_wp
    k = 1
    ! STORE ROOTS ISOLATED BY BALANC
    ! AND COMPUTE MATRIX NORM
    do i = 1, n
       do j = k, n
          norm = norm + abs(h(i, j))
       enddo
       k = i
       if (i < Low .or. i > Igh) then
          Wr(i) = h(i, i)
          Wi(i) = 0.0_wp
       endif
    enddo

    en = Igh
    t = 0.0_wp
    itn = 30*n
    ! SEARCH FOR NEXT EIGENVALUES
    do while (en >= Low)
       gt = 0
       its = 0
       na = en - 1
       enm2 = na - 1
       ! LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
       ! FOR L=EN STEP -1 UNTIL LOW DO --
       do while (.true.)
          do ll = Low, en
             l = en + Low - ll
             if (l == Low) exit
             s = abs(h(l - 1, l - 1)) + abs(h(l, l))
             if (s == 0.0_wp) s = norm
             s2 = s + abs(h(l, l - 1))
             if (s2 == s) exit
          enddo
          ! FORM SHIFT
          x = h(en, en)
          if (l == en) then
             ! ONE ROOT FOUND
             h(en, en) = x + t
             Wr(en) = h(en, en)
             Wi(en) = 0.0_wp
             en = na
             gt = 1
             exit
          else
             y = h(na, na)
             w = h(en, na)*h(na, en)
             if (l == na) exit
             if (itn == 0) then
                ! SET ERROR -- NO CONVERGENCE TO AN
                ! EIGENVALUE AFTER 30*N ITERATIONS
                Ierr = en
                return
             else
                if (its == 10 .or. its == 20) then
                   ! FORM EXCEPTIONAL SHIFT
                   t = t + x
                   do i = Low, en
                      h(i, i) = h(i, i) - x
                   enddo
                   s = abs(h(en, na)) + abs(h(na, enm2))
                   x = 0.75_wp*s
                   y = x
                   w = -0.4375_wp*s*s
                endif
                its = its + 1
                itn = itn - 1
                ! LOOK FOR TWO CONSECUTIVE SMALL
                ! SUB-DIAGONAL ELEMENTS.
                ! FOR M=EN-2 STEP -1 UNTIL L DO --
                do mm = l, enm2
                   m = enm2 + l - mm
                   zz = h(m, m)
                   r = x - zz
                   s = y - zz
                   p = (r*s - w)/h(m + 1, m) + h(m, m + 1)
                   q = h(m + 1, m + 1) - zz - r - s
                   r = h(m + 2, m + 1)
                   s = abs(p) + abs(q) + abs(r)
                   p = p/s
                   q = q/s
                   r = r/s
                   if (m == l) exit
                   s1 = abs(p)*(abs(h(m - 1, m - 1)) + abs(zz) + abs(h(m + 1, m + 1)))
                   s2 = s1 + abs(h(m, m - 1))*(abs(q) + abs(r))
                   if (s2 == s1) exit
                enddo
                mp2 = m + 2
                do i = mp2, en
                   h(i, i - 2) = 0.0_wp
                   if (i /= mp2) h(i, i - 3) = 0.0_wp
                enddo
                ! DOUBLE QR STEP INVOLVING ROWS L TO EN AND
                ! COLUMNS M TO EN
                do k = m, na
                   notlas = k /= na
                   if (k /= m) then
                      p = h(k, k - 1)
                      q = h(k + 1, k - 1)
                      r = 0.0_wp
                      if (notlas) r = h(k + 2, k - 1)
                      x = abs(p) + abs(q) + abs(r)
                      if (x == 0.0_wp) cycle
                      p = p/x
                      q = q/x
                      r = r/x
                   endif
                   s = sign(sqrt(p*p + q*q + r*r), p)
                   if (k == m) then
                      if (l /= m) h(k, k - 1) = -h(k, k - 1)
                   else
                      h(k, k - 1) = -s*x
                   endif
                   p = p + s
                   x = p/s
                   y = q/s
                   zz = r/s
                   q = q/p
                   r = r/p
                   ! ROW MODIFICATION
                   do j = k, n
                      p = h(k, j) + q*h(k + 1, j)
                      if (notlas) then
                         p = p + r*h(k + 2, j)
                         h(k + 2, j) = h(k + 2, j) - p*zz
                      endif
                      h(k + 1, j) = h(k + 1, j) - p*y
                      h(k, j) = h(k, j) - p*x
                   enddo
                   j = min(en, k + 3)
                   ! COLUMN MODIFICATION
                   do i = 1, j
                      p = x*h(i, k) + y*h(i, k + 1)
                      if (notlas) then
                         p = p + zz*h(i, k + 2)
                         h(i, k + 2) = h(i, k + 2) - p*r
                      endif
                      h(i, k + 1) = h(i, k + 1) - p*q
                      h(i, k) = h(i, k) - p
                   enddo
                   ! ACCUMULATE TRANSFORMATIONS
                   do i = Low, Igh
                      !
                      p = x*z(i, k) + y*z(i, k + 1)
                      if (notlas) then
                         p = p + zz*z(i, k + 2)
                         z(i, k + 2) = z(i, k + 2) - p*r
                      endif
                      z(i, k + 1) = z(i, k + 1) - p*q
                      z(i, k) = z(i, k) - p
                      !
                   enddo
                enddo
             endif
          endif
       enddo
       if (gt == 1) cycle
       ! TWO ROOTS FOUND
       p = (y - x)/2.0_wp
       q = p*p + w
       zz = sqrt(abs(q))
       h(en, en) = x + t
       x = h(en, en)
       h(na, na) = y + t
       if (q < 0.0_wp) then
          ! COMPLEX PAIR
          Wr(na) = x + p
          Wr(en) = x + p
          Wi(na) = zz
          Wi(en) = -zz
       else
          ! REAL PAIR
          zz = p + sign(zz, p)
          Wr(na) = x + zz
          Wr(en) = Wr(na)
          if (zz /= 0.0_wp) Wr(en) = x - w/zz
          Wi(na) = 0.0_wp
          Wi(en) = 0.0_wp
          x = h(en, na)
          s = abs(x) + abs(zz)
          p = x/s
          q = zz/s
          r = sqrt(p*p + q*q)
          p = p/r
          q = q/r
          ! ROW MODIFICATION
          do j = na, n
             zz = h(na, j)
             h(na, j) = q*zz + p*h(en, j)
             h(en, j) = q*h(en, j) - p*zz
          enddo
          ! COLUMN MODIFICATION
          do i = 1, en
             zz = h(i, na)
             h(i, na) = q*zz + p*h(i, en)
             h(i, en) = q*h(i, en) - p*zz
          enddo
          ! ACCUMULATE TRANSFORMATIONS
          do i = Low, Igh
             zz = z(i, na)
             z(i, na) = q*zz + p*z(i, en)
             z(i, en) = q*z(i, en) - p*zz
          enddo
       endif
       en = enm2
    enddo
    ! ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
    ! VECTORS OF UPPER TRIANGULAR FORM
    if (norm /= 0.0_wp) then
       ! FOR EN=N STEP -1 UNTIL 1 DO --
       do nn = 1, n
          en = n + 1 - nn
          p = Wr(en)
          q = Wi(en)
          na = en - 1
          if (q < 0) then
             ! END COMPLEX VECTOR
             ! COMPLEX VECTOR
             m = na
             ! LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
             ! EIGENVECTOR MATRIX IS TRIANGULAR
             if (abs(h(en, na)) <= abs(h(na, en))) then
                call cdiv(0.0_wp, -h(na, en), h(na, na) - p, q, h(na, na), h(na, en))
             else
                h(na, na) = q/h(en, na)
                h(na, en) = -(h(en, en) - p)/h(en, na)
             endif
             h(en, na) = 0.0_wp
             h(en, en) = 1.0_wp
             enm2 = na - 1
             if (enm2 /= 0) then
                ! FOR I=EN-2 STEP -1 UNTIL 1 DO --
                do ii = 1, enm2
                   i = na - ii
                   w = h(i, i) - p
                   ra = 0.0_wp
                   sa = h(i, en)
                   !
                   do j = m, na
                      ra = ra + h(i, j)*h(j, na)
                      sa = sa + h(i, j)*h(j, en)
                   enddo
                   !
                   if (Wi(i) >= 0.0_wp) then
                      m = i
                      if (Wi(i) == 0.0_wp) then
                         call cdiv(-ra, -sa, w, q, h(i, na), h(i, en))
                      else
                         ! SOLVE COMPLEX EQUATIONS
                         x = h(i, i + 1)
                         y = h(i + 1, i)
                         vr = (Wr(i) - p)*(Wr(i) - p) + Wi(i)*Wi(i) - q*q
                         vi = (Wr(i) - p)*2.0_wp*q
                         if (vr == 0.0_wp .and. vi == 0.0_wp) then
                            s1 = norm*(abs(w) + abs(q) + abs(x) + abs(y) + abs(zz))
                            vr = s1
                            do while (.true.)
                               vr = 0.5_wp*vr
                               if (s1 + vr <= s1) exit
                            enddo
                            vr = 2.0_wp*vr
                         endif
                         call cdiv(x*r - zz*ra + q*sa, x*s - zz*sa - q*ra, vr, vi, h(i, na), &
                                   h(i, en))
                         if (abs(x) <= abs(zz) + abs(q)) then
                            call cdiv(-r - y*h(i, na), -s - y*h(i, en), zz, q, h(i + 1, na), &
                                      h(i + 1, en))
                         else
                            h(i + 1, na) = (-ra - w*h(i, na) + q*h(i, en))/x
                            h(i + 1, en) = (-sa - w*h(i, en) - q*h(i, na))/x
                         endif
                      endif
                   else
                      zz = w
                      r = ra
                      s = sa
                   endif
                enddo
             endif
          elseif (q == 0) then
             ! REAL VECTOR
             m = en
             h(en, en) = 1.0_wp
             if (na /= 0) then
                ! FOR I=EN-1 STEP -1 UNTIL 1 DO --
                do ii = 1, na
                   i = en - ii
                   w = h(i, i) - p
                   r = h(i, en)
                   if (m <= na) then
                      do j = m, na
                         r = r + h(i, j)*h(j, en)
                      enddo
                   endif
                   if (Wi(i) >= 0.0_wp) then
                      ! END REAL VECTOR
                      m = i
                      if (Wi(i) == 0.0_wp) then
                         t = w
                         if (t == 0.0_wp) then
                            t = norm
                            do while (.true.)
                               t = 0.5_wp*t
                               if (norm + t <= norm) exit
                            enddo
                            t = 2.0_wp*t
                         endif
                         h(i, en) = -r/t
                      else
                         ! SOLVE REAL EQUATIONS
                         x = h(i, i + 1)
                         y = h(i + 1, i)
                         q = (Wr(i) - p)*(Wr(i) - p) + Wi(i)*Wi(i)
                         t = (x*s - zz*r)/q
                         h(i, en) = t
                         if (abs(x) <= abs(zz)) then
                            h(i + 1, en) = (-s - y*t)/zz
                         else
                            h(i + 1, en) = (-r - w*t)/x
                         endif
                      endif
                   else
                      zz = w
                      s = r
                   endif
                enddo
             endif
          endif
       enddo
       ! END BACK SUBSTITUTION.
       ! VECTORS OF ISOLATED ROOTS
       do i = 1, n
          if (i < Low .or. i > Igh) then
             do j = i, n
                z(i, j) = h(i, j)
             enddo
          endif
       enddo
       ! MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
       ! VECTORS OF ORIGINAL FULL MATRIX.
       ! FOR J=N STEP -1 UNTIL LOW DO --
       do jj = Low, n
          j = n + Low - jj
          m = min(j, Igh)
          do i = Low, Igh
             zz = 0.0_wp
             do k = Low, m
                zz = zz + z(i, k)*h(k, j)
             enddo
             z(i, j) = zz
          enddo
       enddo
    endif
 end subroutine hqr2

!*****************************************************************************************
!>
!  Compute the eigenvalues and, optionally, the eigenvectors
!  of a real general matrix.
!
!  This subroutine calls the recommended sequence of
!  subroutines from the eigensystem subroutine package (EISPACK)
!  To find the eigenvalues and eigenvectors (if desired)
!  of a REAL GENERAL matrix.
!
!### References
!  * B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
!    Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
!    system Routines - EISPACK Guide, Springer-Verlag,
!    1976.
!
!### Author
!  * Smith, B. T., et al.
!
!### History  (YYMMDD)
! * 760101  DATE WRITTEN
! * 890831  Modified array declarations.  (WRB)
! * 890831  REVISION DATE from Version 3.2
! * 891214  Prologue converted to Version 4.0 format.  (BAB)
! * 920501  Reformatted the REFERENCES section.  (WRB)
! * 921103  Corrected description of IV1.  (DWL, FNF and WRB)
! * Jacob Williams, refactored into modern Fortran (3/25/2018)

 subroutine rg(Nm, n, a, Wr, Wi, Matz, z, Iv1, Fv1, Ierr)

    implicit none

    integer,intent(in)  :: n   !! the order of the matrix A.
                               !! N must be less than or equal to NM.
    integer,intent(in)  :: Nm  !! must be set to the row dimension of the two-dimensional
                               !! array parameters, A and Z, as declared in the calling
                               !! program dimension statement.
    integer,intent(in)  :: Matz !! an INTEGER variable set equal to zero if only
                                !! eigenvalues are desired.  Otherwise, it is set to any
                                !! non-zero integer for both eigenvalues and eigenvectors.
    real(wp),intent(inout) :: a(Nm, *)   !! contains the real general matrix.
                                         !! dimensioned A(NM,N).
                                         !! Note: A is destroyed on output.
    integer,intent(out)  :: Ierr  !! an INTEGER flag set to:
                                  !!
                                  !! * Zero -- for normal return,
                                  !! * 10*N -- if N is greater than NM,
                                  !! * J    -- if the J-th eigenvalue has not been
                                  !!           determined after a total of 30 iterations.
                                  !!           The eigenvalues should be correct for indices
                                  !!           IERR+1, IERR+2, ..., N, but no eigenvectors are
                                  !!           computed.
    real(wp),intent(out) :: Wr(*)  !! real part of the eigenvalues.  The eigenvalues are unordered except
                                   !! that complex conjugate pairs of eigenvalues appear consecutively
                                   !! with the eigenvalue having the positive imaginary part
                                   !! first.  If an error exit is made, the eigenvalues should be
                                   !! correct for indices IERR+1, IERR+2, ..., N.  WR and WI are
                                   !! one-dimensional REAL arrays, dimensioned WR(N) and WI(N).
    real(wp),intent(out) :: Wi(*)  !! imaginary part of the eigenvalues.
    real(wp),intent(out) :: z(Nm, *) !! contains the real and imaginary parts of the eigenvectors
                                     !! if MATZ is not zero.  If the J-th eigenvalue is real, the
                                     !! J-th column of Z contains its eigenvector.  If the J-th
                                     !! eigenvalue is complex with positive imaginary part, the
                                     !! J-th and (J+1)-th columns of Z contain the real and
                                     !! imaginary parts of its eigenvector.  The conjugate of this
                                     !! vector is the eigenvector for the conjugate eigenvalue.
                                     !! Z is a two-dimensional REAL array, dimensioned Z(NM,N).
    real(wp),intent(inout) :: Fv1(*) !! one-dimensional temporary storage arrays of dimension N.
    integer,intent(inout)  :: Iv1(*) !! one-dimensional temporary storage arrays of dimension N.

    integer  :: is1
    integer  :: is2

    if (n <= Nm) then
       call balanc(Nm, n, a, is1, is2, Fv1)
       call elmhes(Nm, n, is1, is2, a, Iv1)
       if (Matz /= 0) then
          ! find both eigenvalues and eigenvectors
          call eltran(Nm, n, is1, is2, a, Iv1, z)
          call hqr2(Nm, n, is1, is2, a, Wr, Wi, z, Ierr)
          if (Ierr == 0) call balbak(Nm, n, is1, is2, Fv1, n, z)
       else
          ! find eigenvalues only
          call hqr(Nm, n, is1, is2, a, Wr, Wi, Ierr)
       endif
    else
       Ierr = 10*n
    endif

 end subroutine rg
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the eigenvalues and, optionally, the eigenvectors
!  of a real general matrix.
!
!### See also
!  * See [[rg]] for more details. This routine is just a wrapper to that one.
!
!### Author
!  * Jacob Williams, 3/25/2018

    subroutine compute_eigenvalues_and_eigenvectors(n, a, w, z, ierr)

    use numbers_module

    implicit none

    integer,intent(in)                  :: n    !! the order of the matrix `a`
    real(wp),dimension(n,n),intent(in)  :: a    !! contains the real general matrix
    real(wp),dimension(n,2),intent(out) :: w    !! real and imaginary parts of the eigenvalues
    real(wp),dimension(n,n),intent(out) :: z    !! real and imaginary parts of the eigenvectors
    integer,intent(out)                 :: ierr !! output flag from [[rg]]

    integer,parameter :: matz = 1 !! tells [[rg]] to compute eigenvalues and eigenvectors

    integer                 :: i     !! counter
    real(wp),dimension(n,n) :: a_tmp !! copy of [[a]] matrix
    real(wp),dimension(n)   :: fv1   !! work array for [[rg]]
    integer,dimension(n)    :: iv1   !! work array for [[rg]]
    real(wp),dimension(n)   :: wr    !! real part of the eigenvalues
    real(wp),dimension(n)   :: wi    !! imaginary part of the eigenvalues

    ! temp arrays:
    a_tmp = a
    wr = zero
    wi = zero

    ! call the general routine:
    call rg(n, n, a_tmp, wr, wi, matz, z, iv1, fv1, ierr)

    ! pack outputs:
    do i=1,n
        w(i,1) = wr(i)
        w(i,2) = wi(i)
    end do

    end subroutine compute_eigenvalues_and_eigenvectors
!*****************************************************************************************

!*****************************************************************************************
  end module eispack_module
!*****************************************************************************************


	real r (180), t (180)
c
	do 10 i = 1, 180
		t (i) = 2.*i - 2.
		r (i) = 1. + sin (t (i) * .01745329)
10              continue
	call setpen (2)
c       call setmtf ('card.mtf', 8)
	call page (30., 22., 'CARDIOIDE', 9, 1)
	call polreg (15., 11., 0., 10., 0., 360., 0, 0, 0., 0)
	call setpen (1)
	call limits (0., 2.2, 0., 360.)
	call poline (r, t, 180, -1, 1, 0, 1)
	call limits (0., 2.2, 360., 0.)
	call poline (r, t, 180, -1, 1, 0, 1)
	call setpen (6)
	call raxes ('RADIUS', 6, 0.5, 0.5, 1, 1, 0.)
	call setpen (3)
	call thaxes ('ANGLE', -5, 0.5, 30., 1, 1, 2.1)
	call setpen (5)
	call endpg ('kard')
	end


!  pt_in_poly2: point-in-polygon test.
!  signa: signed area (double prevision)
!====================================================================
!====================================================================

      subroutine pt_in_poly2(nvertices,xpoly,ypoly,xtest,ytest,in_out,inters,npoly)
!     (Double-precision) Routine to perform point-in-polygon
!     test. Polygon may be multi-connected (and concave), and
!     the list of vertices can be either clock- or counter-clockwise.
!     The 1st vertex of each poly must be repeated, and 1 sub-polygon must
!     completely enclose all others, and sub-poly's do not cross each other.
!     Inputs:
!            nvertices: # of polygonal vertices. 1st vertex of each sub-poly
!            must be repeated.
!            xpoly(nvertices),ypoly(nvertices): list of vertices
!            xtest,ytest: test point
!     Outputs:
!            in_out: -1 if outside, 0 if on the polygon, 1 if inside
!            inters: # of intersections (no accurate if in_out=0). If
!            outside bounding box of poly, inters=-1.
!            npoly: # of sub-poly's found
!     Error: fort.11 (fatal)
!     Method: ray tracing method by testing each side of polygons and a
!     ray from the test point to infty along an angle. The point is
!     outside if the ray intersects polygonal sides odd # of times,
!     inside if even # of times. Check separately if on the side based
!     on a tolerance (small1).
!     Assume that the ray is not parallel to any side and also the
!     intersection does not coincide with any vertices if the test pt
!     is not one of them. If fatal error occurs, adjust
!     ray_angle or small1.
      implicit real*8(a-h,o-z)
      integer, intent(in) :: nvertices
      real*8, intent(in) :: xpoly(nvertices),ypoly(nvertices),xtest,ytest
      integer, intent(out) :: in_out,inters,npoly

      !Local
      real*8, parameter :: pi=3.1415926d0
      real*8, parameter :: small1=1.e-5 !tolerance
      real*8 :: ray_angle=3.13192 !degr - use a real number to enhance randomness
      integer :: list(3),firstv_poly(nvertices),endv_poly(nvertices)

      !Find # of poly's
      endv_poly=-99 !flag
      npoly=1
      firstv_poly(npoly)=1 !1st vertex
      i=2 !starting vertex for searching
      do
        j=firstv_poly(npoly)
        rl=(xpoly(i)-xpoly(j))**2+(ypoly(i)-ypoly(j))**2
        if(rl<small1*1.d-3) then
          endv_poly(npoly)=i
          if(i+1==nvertices) then
            write(11,*)'pt_in_poly2: last poly has only 1 vertex'
            stop
          else if(i+1<nvertices) then
            npoly=npoly+1
            firstv_poly(npoly)=i+1
            i=i+1 !skip 1st vertex in the next iteration
          endif
        endif

        i=i+1
        if(i>nvertices) exit
      enddo !i

      !print*, npoly,' polygons found'

      do i=1,npoly
        if(endv_poly(i)<=0) then
          write(11,*)'pt_in_poly2: end not closed, ',i,firstv_poly(i)
          stop
        endif
        if(endv_poly(i)<firstv_poly(i)+3) then
          print*, 'pt_in_poly2: improper poly, ',i,firstv_poly(i),endv_poly(i)
          stop
        endif

        !Debug
        !write(40+i,*)
        !write(40+i,*)endv_poly(i)-firstv_poly(i)+1
        !do j=firstv_poly(i),endv_poly(i)
        !  write(40+i,*)j,real(xpoly(j)),real(ypoly(j)),real(i)
        !enddo !j
      enddo !i

      in_out=-1 !init as outside; change sign each time the ray crosses a side
      inters=0
      !Bounding box
      xmin=minval(xpoly); xmax=maxval(xpoly)
      ymin=minval(ypoly); ymax=maxval(ypoly)
      if(xtest<xmin.or.xtest>xmax.or.ytest<ymin.or.ytest>ymax) then
        !outside
        in_out=-1; inters=-1
        return
      endif

      an2=ray_angle/180*pi
      cosa=cos(an2); sina=sin(an2)
      loop1: do i=1,npoly
        do j=firstv_poly(i),endv_poly(i)-1
          j2=j+1
          !Calc intersection btw 2 lines:
          !L1: x=x_0+(cos,sin)*t1 (t1>=0) (x_0 is the test pt)
          !L2: x=x_1+(x_2-x_1)*t2 (0<=t2<=1) (x_{1,2} are side pts)
          x0=xtest; y0=ytest
          x1=xpoly(j); x2=xpoly(j2)
          y1=ypoly(j); y2=ypoly(j2)
          delta=(y1-y2)*cosa-(x1-x2)*sina
          if(delta==0) then
            write(11,*)'pt_in_poly2, delta=0:',i,j,delta
            stop
          endif
          t1=((x1-x0)*(y1-y2)-(y1-y0)*(x1-x2))/delta
          t2=((y1-y0)*cosa-(x1-x0)*sina)/delta
          if(t2>=0.and.t2<=1) then
            if(abs(t1)<small1) then !on the side
              in_out=0; exit loop1
            else if(t1>0) then
              if(t2==0.or.t2==1) then !ambiguous intersection (with at least 2 sides)
                write(11,*)'pt_in_poly2: plz adjust ray_angle:',i,j,t1,t2
                stop
              endif

              !Exactly 1 intersection
              in_out=-in_out
              inters=inters+1

              !Debug
              !xin=x0+cosa*t1
              !yin=y0+sina*t1
              !write(98,*)inters,real(xin),real(yin),i,j,j2

            endif
          endif !t2
        enddo !j
      end do loop1 !i=1,npoly

      end subroutine pt_in_poly2

!====================================================================
      function signa(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      implicit real*8(a-h,o-z)

      signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      end
!====================================================================

!     Test driver
!     ifort -Bstatic -O2 -mcmodel=medium -o pt_in_poly2 pt_in_poly2.f90
!      program test_pt_in_poly2
!      implicit real*8(a-h,o-z)
!      real*8, allocatable :: xpoly(:),ypoly(:)
!
!      !Use gredit/regions to generate a multi-connected poly
!      !Make sure to repeat 1st vertex of each sub-poly
!      open(12,file='multi.xy',status='old')
!      open(10,file='test_pts.bp',status='old')
!      read(12,*)nvertices
!      allocate(xpoly(nvertices),ypoly(nvertices))
!      do i=1,nvertices
!        read(12,*)xpoly(i),ypoly(i)
!      enddo !i
!      close(12)
!      read(10,*); read(10,*)npts
!      do i=1,npts
!        read(10,*)j,xtest,ytest
!
!        !Debug
!        write(98,*)'Test pt #',i
!
!        call pt_in_poly2(nvertices,xpoly,ypoly,xtest,ytest,in_out,inters)
!        print*, 'Point ',i,in_out,inters
!      enddo !i
!
!      !Test a pt on poly
!      xtest=0.53*xpoly(nvertices)+(1-0.53)*xpoly(nvertices-1)
!      ytest=0.53*ypoly(nvertices)+(1-0.53)*ypoly(nvertices-1)
!      call pt_in_poly2(nvertices,xpoly,ypoly,xtest,ytest,in_out,inters,npoly)
!      print*, 'Extra pt on poly:',in_out,inters
!
!      end program test_pt_in_poly2


          program demo_makepoly
          use :: M_draw
          implicit none
          integer,parameter :: wide=640, tall=640
          integer :: rows, xoff, yoff, box_sz
          integer :: i20, i30, ncols, nrows, ilines
          real    :: bottom, left, sun_radius, planet_radius, planet_offset
          integer :: ipaws
             call prefsize(wide,tall)
             call vinit(' ') ! start graphics using device $M_draw_DEVICE
             call ortho2(0.0, real(wide), 0.0, real(tall) )
             ! call linewidth(3) ! really slows down pbm driver because all lines are polygons
             call color(D_WHITE)
             call clear()
             call color(D_BLACK)
             rows=1
             box_sz=MIN(wide,tall)/rows       ! size of biggest box to use and get specified number of rows
             nrows = tall/box_sz              ! number of rows of objects to draw
             ncols = wide/box_sz              ! number of columns of objects to draw
             xoff = (wide - ncols * box_sz)/2 ! initial x offset to begin row at to center drawings
             yoff = (tall - nrows * box_sz)/2 ! initial x offset to begin column at to center drawings
             sun_radius = 148
             planet_radius = 1
             do ilines = 1, 300
                do i20 = 1, ncols
                   left = (i20-1)*box_sz+xoff
                   do i30 = 1, nrows
                      bottom = (i30-1)*box_sz+yoff
                      call color(D_BLACK)
                   call makepoly()
                      call rect(left,bottom,left+box_sz,bottom+box_sz)
                   call closepoly()
                      planet_offset= sun_radius
                         call color(mod(ilines,15)+1)
                         call hypoc(left + box_sz/2.0, bottom + box_sz/2.0, &
                      & sun_radius, planet_radius, planet_offset, &
                      & box_sz/2.0, ilines,  &
                      & 0.0, 0.0, 1)
                   enddo
                enddo
                ipaws=getkey()
             enddo
             call vexit()
          contains
          !
          !  Make shapes using hypocycloidal curves.
          !
          subroutine hypoc(xcenter,ycenter,sunr0,planet0,offset0,radius,ilines,ang,angs,ifill)
          use M_draw
          implicit none
          real,parameter     :: PI= 3.14159265358979323846264338327950288419716939937510
          real,intent(in)    :: xcenter, ycenter      ! center of curve
          real,intent(in)    :: sunr0,planet0,offset0 ! radii of sun, planet, and planet offset
          real,intent(in)    :: radius                ! radius to fit the shape to (no fit if radius is 0)
          integer,intent(in) :: ilines                ! number of points to sample along curve
          real,intent(in)    :: ang                   ! angle to rotate the shape by, to orientate it.
          real,intent(in)    :: angs                  ! angle to start sampling points at; ccw is +; 0 is East
          integer,intent(in) :: ifill                 ! 1 make a filled polygon, 2 make a hatched polygon
          integer            :: i10
          real               :: ang1, con1, con2, factor
          real               :: offset, planet, r, sunr, u
          real               :: xpoin, xpoin1, ypoin, ypoin1
             sunr=sunr0
             offset=offset0
             planet=planet0
             if(ilines.eq.0.0) return
             if(planet.eq.0.0) return
             if(sunr.eq.0.0)   return
             if(radius.ne.0.and.sunr-planet+offset.ne.0)then
                factor=radius/(sunr-planet+offset)
                sunr=factor*sunr
                planet=factor*planet
                offset=factor*offset
             endif
             u=0.0+ang
             con1=PI*2.*(sunr/planet)/real(ilines)
             con2=(1.0-planet/sunr)*u
             xpoin1=(sunr-planet)*cos(planet*u/sunr)+offset*cos(con2)
             ypoin1=(sunr-planet)*sin(planet*u/sunr)-offset*sin(con2)
             ang1=atan2(ypoin1,xpoin1)+angs
             r=sqrt(xpoin1**2+ypoin1**2)
             xpoin1=r*cos(ang1)+xcenter
             ypoin1=r*sin(ang1)+ycenter
             select case(ifill)
             case(:0)
             case(1:)
                call makepoly()
             end select
             call move2(xpoin1,ypoin1)
             do i10=1,ilines
                u=con1*i10+ang
                con2=(1.0-planet/sunr)*u
                if(con2.ge.2**24) con2=amod(con2,PI)
                xpoin=(sunr-planet)*cos(planet*u/sunr)+offset*cos(con2)
                ypoin=(sunr-planet)*sin(planet*u/sunr)-offset*sin(con2)
                ang1=atan2(ypoin,xpoin)+angs
                r=sqrt(xpoin**2+ypoin**2)
                xpoin=r*cos(ang1)+xcenter
                ypoin=r*sin(ang1)+ycenter
                call draw2(xpoin,ypoin)
             enddo
             call draw2(xpoin1,ypoin1)
             if(ifill.gt.0)then
               call closepoly()
             endif
          end subroutine hypoc
          end program demo_makepoly


      subroutine tanhrt(nb, Rval, tn, nTimes, vecTcalc, vecRTrel)

  !====================================================================
  ! Hyperbolic Tangent Model for R(t)
  !
  !====================================================================
      implicit none

      integer nb, nTimes
      real*8 Rval(nb), tn(nb)
      real*8 vecTcalc(nTimes), vecRTrel(ntimes)
      real*8 wl
      parameter (wl = 5.0d0)
      real*8 t_cur, beta_tmp
      integer i, j

 ! convert from absolute days in each R(t) value to relative number of days

      do i = 2, (nb-1)
         tn(i) = tn((i-1)) + tn(i)
      enddo

      do j = 1, nTimes
         t_cur = vecTcalc(j)
!     Calculate R(t)
         beta_tmp = Rval(1) + Rval(nb)
         do i = 2, nb
            beta_tmp = beta_tmp + (Rval(i) - Rval((i-1))) *
     $           tanh((t_cur-tn((i-1)))/wl)
         enddo
         beta_tmp = beta_tmp * 0.5
         vecRTrel(j) = beta_tmp
      enddo

      return
      end subroutine tanhrt


!       VERSION 1.0     2/5/99
!**********************************************************************

!                    ===================
!                       function W3J
!                    ===================

!       This double precision function will calculate the values of
!       the Wigner 3-J symbols used in the Stochastic Liouville matrix
!       formulation of the slow-motional EPR calculation, i.e.

!                         ( J1  J2  J3 )
!                         ( M1  M2  M3 )

!       For J2 <= 2 and arbitrary J1 and J3, this routine explicitly
!       evaluates formulae given in Table 2 of "Angular Momentum in
!       Quantum Mechanics" by A. R. Edmonds, revised 2nd printing,
!       Princeton Univ. Press, 1968.

!       For J2 > 2 and J1,J3 < Lmax (MXLVAL defined in 'limits.inc' not 'maxl.inc'),
!       this functions calls a modified version of code from
!       Prof. C.C.J. Roothan, function wig3j, which appears in this file.

!       NOTE: Before any calls to function w3j are made, it is
!       necessary to set up a list of binomial coefficients in
!       common block /bincom/ by calling subroutine bincof. This
!       is now handled automatically by function wig3j (see below).

!       Written by D.J. Schneider, 5/7/90
!       Updated by D.E.Budil 1/10/93 to fix bug for J2=1

!  Coded in this file:
!     w3j(n1,n2,n3,n4,n5,n6)
!     bincof()
!     wig3j(n1,n2,n3,n4,n5,n6)

!  Includes:
!    maxl.inc

!**********************************************************************

    function w3j(n1,n2,n3,n4,n5,n6)
    double precision :: w3j
    integer :: n1,n2,n3,n4,n5,n6

    include 'limits.inc'

    integer :: j1,j2,j3,m1,m2,m3,jdelta,k
    double precision :: phase,parity,x,y,z,ztemp1,ztemp2

    double precision :: wig3j

!######################################################################

!----------------------------------------------------------------------
!       check triangle conditions, etc.
!----------------------------------------------------------------------

    if ((n1 < 0) .OR. (n2 < 0) .OR. (n3 < 0) .OR. &
    ((n2 > 2) .AND. (n1+n2+n3+1 > 2*(MXLVAL+8)+1))) then
        write (*,*) '*** quantum nubers too large in w3j ***',n1,n2,n3,n4,n5,n6
        stop
    end if

    if ((abs(n4) > n1) .OR. (abs(n5) > n2) .OR. (abs(n6) > n3) .OR. &
    ((n4+n5+n6) /= 0) .OR. &
    ((n1+n2) < n3) .OR. ((n1+n3) < n2) .OR. ((n2+n3) < n1)) then
        w3j=0.0d0
        return
    end if

    j1=n1
    j2=n2
    j3=n3
    m1=n4
    m2=n5
    m3=n6

!----------------------------------------------------------------------
!       use wig3j to calculate if j2 > 2
!----------------------------------------------------------------------

    if (n2 > 2) then
        w3j=wig3j(j1,j2,j3,m1,m2,m3)
        return
    end if

!----------------------------------------------------------------------
!       permute variables if necessary to get m2 => 0 and j1 <= j3,
!       keep track of phases, and store variables
!----------------------------------------------------------------------

    j1=n1
    j2=n2
    j3=n3
    m1=n4
    m2=n5
    m3=n6

    phase=1.0d0

    if (mod(j1+j2+j3,2) == 0) then
        parity=1.d0
    else
        parity=-1.d0
    end if

    if (m2 < 0) then
        m1=-m1
        m2=-m2
        m3=-m3
        phase=parity
    else
        phase=1.d0
    end if

    if(j1 > j3) then
        k=j1
        j1=j3
        j3=k
        k=m1
        m1=m3
        m3=k
        phase=phase*parity
    end if

    if (mod(j1-m3,2) /= 0) then
        phase=-phase
    end if

!----------------------------------------------------------------------
!        calculate wigner 3-j symbols
!----------------------------------------------------------------------

    jdelta=j3-j1
    x=dble(j1+j3-1)
    y=dble(j1-m3)
    z=dble(j1+m3)

    if (j2 == 0) then
        w3j=phase/sqrt(dble(2*j1+1))
    else if (j2 == 2) then
        ztemp2=x*(x+1.0d0)*(x+2.0d0)*(x+3.0d0)*(x+4.0d0)
        if (m2 == 0) then
            if (jdelta == 0) then
                ztemp1=2.0d0*dble(3*m3*m3-j1*(j1+1))
                w3j=phase*ztemp1/sqrt(ztemp2)
            else if (jdelta == 1) then
                ztemp1=6.0d0*(z+1.0d0)*(y+1.0d0)
                w3j=-phase*2.0d0*dble(m3)*sqrt(ztemp1/ztemp2)
            else
                ztemp1=6.0d0*(z+2.0d0)*(z+1.0d0) &
                *(y+2.0d0)*(y+1.0d0)
                w3j=phase*sqrt(ztemp1/ztemp2)
            end if
        else if (m2 == 1) then
            if (jdelta == 0) then
                ztemp1=6.0d0*(z+1.0d0)*y
                w3j=phase*dble(2*m3+1) &
                *sqrt(ztemp1/ztemp2)
            else if (jdelta == 1) then
                ztemp1=y*(y+1.0d0)
                w3j=-phase*dble(2*j1+4*m3+4)* &
                sqrt(ztemp1/ztemp2)
            else
                ztemp1=(z+2.0d0)*y*(y+1.0d0)*(y+2.0d0)
                w3j=phase*2.0d0*sqrt(ztemp1/ztemp2)
            end if
        else
            if (jdelta == 0) then
                ztemp1=6.0d0*(y-1.0d0)*y &
                *(z+1.0d0)*(z+2.0d0)
                w3j=phase*sqrt(ztemp1/ztemp2)
            else if (jdelta == 1) then
                ztemp1=(y-1.0d0)*y*(y+1.0d0)*(z+2.0d0)
                w3j=-phase*2.d0*sqrt(ztemp1/ztemp2)
            else
                ztemp1=(y-1.0d0)*y*(y+1.0d0)*(y+2.0d0)
                w3j=phase*sqrt(ztemp1/ztemp2)
            end if
        end if

    else
        ztemp2=(x+1.0d0)*(x+2.0d0)*(x+3.0d0)
        if (m2 == 0) then
            if (jdelta == 0) then
                w3j=-phase*2.0*dble(m3)/sqrt(ztemp2)
            else
                ztemp1=2.0d0*(y+1.0d0)*(z+1.0d0)
                w3j=-phase*sqrt(ztemp1/ztemp2)
            end if
        else
            if (jdelta == 0) then
                ztemp1=2.0d0*y*(z+1.0d0)
                w3j=-phase*sqrt(ztemp1/ztemp2)
            else
                ztemp1=y*(y+1.0d0)
                w3j=-phase*sqrt(ztemp1/ztemp2)
            end if
        end if
    end if

    return
    end function w3j

!----------------------------------------------------------------------

!                      =========================
!                                BINCOF
!                      =========================

!   Generates an array of binomial coefficients for use with function
!   This must be called before wig3j can calculate a 3-J symbol,
!   and is automatically called by wig3j if the array has not been
!   initialized.

!                         Designed and coded by
!                        Clemens C. J. Roothaan
!                        Department of Chemistry
!                         University of Chicago
!                        5735 South Ellis Avenue
!                        Chicago, Illinois 60637
!                           December 9, 1988

!                   modified by DJS 5/7/90, DEB 5/20/92, DEB 1/10/93

!     MODIFIED 5/20/92 by DEB: added scaling to prevent overflows
!       at high values of MXLVAL
!       The scale factor should be the maximum of (machep,cubmax)
!       where "machep" is the machine precision and  "cubmax" is
!       the inverse cube root of the largest number that can be
!       represented on a given machine. In absence of other information,
!       set scale to unity.

!     Basic vector coupling coefficient package for calculating 3n-j
!     symbols.  All the entries are fortran functions; formally:

!     bincof()                        generate binomial coefficients in bincom
!     wig3j(a,b,c,alpha,beta,gamma)   calculate a 3-j symbol
!----------------------------------------------------------------------

    subroutine bincof()

!    include 'maxl.inc'
    include 'limits.inc'

! --- common BINCOM ------------------------
    integer :: nb,nbncf
    parameter (nb=2*(MXLVAL+8)+2)
    parameter (nbncf=nb*(nb+1)+1)

    integer :: bncfx
    double precision :: bncf,scale,scal3,scal15
    common /bincom/bncf(nbncf),bncfx(nb),scale,scal3,scal15
! ------------------------------------------

    integer :: i,j,ij
    double precision :: bncf0,temp

    scale=1.0D-25
    scal3=(1.0D0/scale)**3
    scal15=dsqrt(scal3)

    ij=1
    do 20 i=0,nb-1
        bncfx(i+1)=ij
        if (i /= 0) then
            bncf0=0.0d0
            do 10 j=1,i
                temp=bncf(ij-i)
                bncf(ij)=bncf0+temp
                bncf0=temp
                ij=ij+1
            10 END DO
        end if
        bncf(ij)=scale
        ij=ij+1
    20 END DO

    return
    end subroutine bincof

!----------------------------------------------------------------------
!                    =========================
!                         function WIG3J
!                    =========================

!     Calculates arbitrary 3-J symbol using binomial coefficients
!     for J values up to an limit determined by the machine precision
!     (approx. 125 for IEEE format real*8 floating-point numbers -DEB)

!     This replaces the function of the same name written by G. Moro
!     for use with EPR spectral simulations.

!                         Designed and coded by
!                        Clemens C. J. Roothaan
!                        Department of Chemistry
!                         University of Chicago
!                        5735 South Ellis Avenue
!                        Chicago, Illinois 60637
!                           December 9, 1988

!                   modified by DJS 5/7/90, DEB 1/10/93
!----------------------------------------------------------------------

    function wig3j(j1,j2,j3,m1,m2,m3)
    double precision :: wig3j
    integer :: j1,j2,j3,m1,m2,m3
    logical :: notset
    data notset / .true. /

!    include 'maxl.inc'
    include 'limits.inc'

! --- common BINCOM ------------------------
    integer :: nb,nbncf
    parameter (nb=2*(MXLVAL+8)+2)
    parameter (nbncf=nb*(nb+1)+1)

    integer :: bncfx
    double precision :: bncf,scale,scal3,scal15
    common /bincom/bncf(nbncf),bncfx(nb),scale,scal3,scal15
! ------------------------------------------

!......................................................................

    integer :: i,j,k,l,m,n,p,q,z,zmin,zmax,bp,bnj,bmk
    double precision :: sum

    if (notset) then
        call bincof
        notset = .false.
    end if

    i=j1+m1
    j=j1-m1
    k=j2+m2
    l=j2-m2
    m=j2+j3-j1
    n=j3+j1-j2
    p=j1+j2-j3
    q=j1+j2+j3 + 1

    if(q+1 > nb) then
        write (*,1000) j1,j2,j3,m1,m2,m3
        return
    endif

    bp=bncfx(p+1)
    bnj=bncfx(n+1)+n-j
    bmk=bncfx(m+1)+m-k
    zmin=max(0,j-n,k-m)
    zmax=min(p,j,k)

    sum=0.0d0
    do 30 z=zmin,zmax
        sum=-sum+bncf(bp+z)*bncf(bnj+z)*bncf(bmk+z)*scal3
    30 END DO

    if (sum /= 0.0d0) then
        if (mod(i+l+zmax,2) /= 0) sum=-sum
        sum=sum*sqrt(bncf(bncfx(q)+m)/ &
        bncf(bncfx(q)+i))/ &
        sqrt(bncf(bncfx(q-i)+k))* &
        sqrt(bncf(bncfx(q-m)+n)/ &
        bncf(bncfx(q)+j))/ &
        sqrt(bncf(bncfx(q-j)+l))/ &
        sqrt(bncf(bncfx(q+1)+1))
    endif

    wig3j=sum/scal15
    return

!######################################################################

    1000 format(' wig3j called with (',6(i3,','),'):'/ &
    '   sum of L values exceeds limit')
    end function wig3j


\ -----------------------------------------------------------------------------
\  Brain's Brain
\  Cellular Automata
\  Michel Jean 2019
\ -----------------------------------------------------------------------------

S" Pixel.f" INCLUDED

320 constant largeur-monde \
200 constant hauteur-monde
largeur-monde hauteur-monde * constant dim-monde

variable pos-X
variable pos-Y

0 pos-X !
0 pos-Y !

\ ===========================================================

create  monde dim-monde allot
create  monde-buf dim-monde allot

variable *monde
variable *monde-buf
variable tampon

variable total \ nbr voisins
variable etat

' monde *monde !
' monde-buf *monde-buf !

: last-bit ( n -- )
2 mod ;

: centre ( n -- )
*monde @ + c@
;
\ 9 voisins possibles
: est ( n -- )
	1 + dim-monde mod *monde @ + c@ last-bit ;

: ouest ( n -- )
	1 - dim-monde mod *monde @ + c@ last-bit ;

: nord ( n -- )
	largeur-monde - dim-monde mod *monde @ + c@ last-bit ;

: sud ( n -- )
	largeur-monde + dim-monde mod *monde @ + c@ last-bit ;

: nord-est ( n -- )
	largeur-monde - 1 + dim-monde mod *monde @ + c@ last-bit ;

: nord-ouest ( n -- )
	largeur-monde - 1 - dim-monde mod *monde @ + c@ last-bit ;

: sud-est ( n -- )
	largeur-monde + 1 + dim-monde mod *monde @ + c@ last-bit ;

: sud-ouest ( n -- )
	largeur-monde + 1 - dim-monde mod *monde @ + c@ last-bit ;

\ voisinage de moore

: moore ( n -- ) \ returne le nombre de voisins

	dup nord-ouest
	swap dup nord
	swap dup nord-est
	swap dup est
	swap dup sud-est
	swap dup sud
	swap dup sud-ouest
	swap ouest
;

: somme-moore
	moore
	+ + + + + + +
;

: brain
	dup
	centre etat c! \ l'état est 1 ou 0, vivant ou mort
	somme-moore total c!

	etat @ 0 = total @ 2 = and if 1 etat c! else
	etat @ 1 = if 2 etat c! else \ introduit un état réfractaire
	etat @ 2 = if 0 etat c! else
	0 etat c!
	then then then
	etat c@
;
\ =========================================

: initialisation ( -- ) \ monde aléatoire
	*monde @ dim-monde 0 fill
	dim-monde 0 do 16 random
	1 = if 1 *monde @ i + c! then loop
;

: regenere-monde
	dim-monde 0 do i brain *monde-buf @ i + c! loop
	*monde tampon 1 cells move
	*monde-buf *monde 1 cells move
	tampon *monde-buf 1 cells move
;

: dessine-monde ( -- )
	largeur-monde 0 do
	hauteur-monde 0 do
		largeur-monde i * j + *monde @ + c@ 1 = if
			j i green pixel else
		largeur-monde i * j + *monde @ + c@ 2 = if
			j i red pixel else
				j i black pixel

	then then
	loop loop
;

: run
	initialisation
	set-screen
	dessine-monde
	do
		dessine-monde
		regenere-monde
		view
		10 pause
	loop
;

run