!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     This file contains a multiple fft package for spherepack. It
!     includes code and documentation for performing fast Fourier
!     transforms (see subroutines hrffti, hrfftf and hrfftb)
!
module type_RealPeriodicFastFourierTransform

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        PI, &
        TWO_PI, &
        odd

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: hrffti, hrfftf, hrfftb
    public :: RealPeriodicFastFourierTransform

    ! Parameters confined to the module
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    real(wp),    parameter :: SQRT_2 = sqrt(TWO)
    integer(ip), parameter :: NUMBER_OF_FACTORS = 15_ip

    type, public :: RealPeriodicFastFourierTransform
    contains
        ! Type-bound procedures
        procedure, nopass :: initialize => hrffti
        procedure, nopass :: forward => hrfftf
        procedure, nopass :: backward => hrfftb
    end type RealPeriodicFastFourierTransform

contains

    ! Purpose:
    !
    !     subroutine hrffti(n, wsave)
    !
    !     subroutine hrffti initializes the array wsave which is used in
    !     both hrfftf and hrfftb. the prime factorization of n together
    !     with a tabulation of the trigonometric functions are computed and
    !     stored in wsave.
    !
    !     input parameter
    !
    !     n       the length of the sequence to be transformed.
    !
    !     output parameter
    !
    !     wsave   a work array which must be dimensioned at least n+15.
    !             the same work array can be used for both hrfftf and
    !             hrfftb as long as n remains unchanged. different wsave
    !             arrays are required for different values of n. the
    !             contents of wsave must not be changed between calls
    !             of hrfftf or hrfftb.
    !
    pure subroutine hrffti(n, wsave)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        real(wp),    intent(out) :: wsave(n+NUMBER_OF_FACTORS)

        ! Local variables
        integer(ip) :: iw1, iw2

        if (n > 1) then

            ! Set wavetable index pointers
            iw1 = 1
            iw2 = n + 1

            call precompute_factorization_and_trig_lookup_table(n, wsave(iw1:), wsave(iw2:))
        end if

    end subroutine hrffti

    ! Purpose:
    !
    !     subroutine hrfftf(m, n, r, mdimr, wsave)
    !
    !     Computes the Fourier coefficients of m real
    !     perodic sequences (Fourier analysis); i.e. hrfftf computes the
    !     real fft of m sequences each with length n. the transform is
    !     defined below at output parameter r.
    !
    !     input parameters
    !
    !     m       the number of sequences.
    !
    !     n       the length of all m sequences.  the method is most
    !             efficient when n is a product of small primes. n may
    !             change as long as different work arrays are provided
    !
    !     r       r(mdimr, n) is a two dimensional real array that contains mdimr
    !             sequences each with length n.
    !
    !     mdimr   the first dimension of the r array as it appears
    !             in the program that calls hrfftf. mdimr must be
    !             greater than or equal to m.
    !
    !
    !     wsave   a work array with at least least n+15 locations
    !             in the program that calls hrfftf. the wsave array must be
    !             initialized by calling subroutine hrffti(n, wsave) and a
    !             different wsave array must be used for each different
    !             value of n. this initialization does not have to be
    !             repeated so long as n remains unchanged thus subsequent
    !             transforms can be obtained faster than the first.
    !             the same wsave array can be used by hrfftf and hrfftb.
    !
    !     work    a real work array with m*n locations.
    !
    !
    !     output parameters
    !
    !     r      for all j=1, ..., m
    !
    !             r(j, 1) = the sum from i=1 to i=n of r(j, i)
    !
    !             if n is even set l =n/2   , if n is odd set l = (n+1)/2
    !
    !               then for k = 2, ..., l
    !
    !                  r(j, 2*k-2) = the sum from i = 1 to i = n of
    !
    !                       r(j, i)*cos((k-1)*(i-1)*2*pi/n)
    !
    !                  r(j, 2*k-1) = the sum from i = 1 to i = n of
    !
    !                      -r(j, i)*sin((k-1)*(i-1)*2*pi/n)
    !
    !             if n is even
    !
    !                  r(j, n) = the sum from i = 1 to i = n of
    !
    !                       (-1)**(i-1)*r(j, i)
    !
    !      *****  note
    !                  this transform is unnormalized since a call of hrfftf
    !                  followed by a call of hrfftb will multiply the input
    !                  sequence by n.
    !
    !     wsave   contains results which must not be destroyed between
    !             calls of hrfftf or hrfftb.
    !
    subroutine hrfftf(m, n, r, mdimr, wsave)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        real(wp),    intent(inout)  :: r(mdimr, n)
        integer(ip), intent(in)     :: mdimr
        real(wp),    intent(in)     :: wsave(n+NUMBER_OF_FACTORS)

        ! Local variables
        integer(ip) :: iw1, iw2

        if (n > 1) then

            ! Set workspace index pointers
            iw1 = 1
            iw2 = n + 1

            call forward_lower_utility_routine(m, n, r, mdimr, &
                wsave(iw1:), wsave(iw2:))
        end if

    end subroutine hrfftf

    ! Purpose:
    !
    !     subroutine hrfftb(m, n, r, mdimr, wsave, work)
    !
    !     subroutine hrfftb computes the real perodic sequence of m
    !     sequences from their Fourier coefficients (Fourier synthesis).
    !     the transform is defined below at output parameter r.
    !
    !     input parameters
    !
    !     m       the number of sequences.
    !
    !     n       the length of all m sequences.  the method is most
    !             efficient when n is a product of small primes. n may
    !             change as long as different work arrays are provided
    !
    !     r       r(mdimr, n) is a two dimensional real array that contains
    !             the Fourier coefficients of m sequences each with
    !             length n.
    !
    !     mdimr   the first dimension of the r array as it appears
    !             in the program that calls hrfftb. mdimr must be
    !             greater than or equal to m.
    !
    !     wsave   a work array which must be dimensioned at least n+15.
    !             in the program that calls hrfftb. the wsave array must be
    !             initialized by calling subroutine hrffti(n, wsave) and a
    !             different wsave array must be used for each different
    !             value of n. this initialization does not have to be
    !             repeated so long as n remains unchanged thus subsequent
    !             transforms can be obtained faster than the first.
    !             the same wsave array can be used by hrfftf and hrfftb.
    !
    !     work    a real work array with m*n locations.
    !
    !
    !     output parameters
    !
    !     r      for all j=1, ..., m
    !
    !             for n even and for i = 1, ..., n
    !
    !                  r(j, i) = r(j, 1)+(-1)**(i-1)*r(j, n)
    !
    !                       plus the sum from k=2 to k=n/2 of
    !
    !                        2.0*r(j, 2*k-2)*cos((k-1)*(i-1)*2*pi/n)
    !
    !                       -2.0*r(j, 2*k-1)*sin((k-1)*(i-1)*2*pi/n)
    !
    !             for n odd and for i = 1, ..., n
    !
    !                  r(j, i) = r(j, 1) plus the sum from k=2 to k=(n+1)/2 of
    !
    !                       2.0*r(j, 2*k-2)*cos((k-1)*(i-1)*2*pi/n)
    !
    !                      -2.0*r(j, 2*k-1)*sin((k-1)*(i-1)*2*pi/n)
    !
    !      *****  note
    !                  this transform is unnormalized since a call of hrfftf
    !                  followed by a call of hrfftb will multiply the input
    !                  sequence by n.
    !
    !     wsave   contains results which must not be destroyed between
    !             calls of hrfftb or hrfftf.
    !
    subroutine hrfftb(m, n, r, mdimr, wsave)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        real(wp),    intent(inout)  :: r(mdimr, n)
        integer(ip), intent(in)     :: mdimr
        real(wp),    intent(in)     :: wsave(n+NUMBER_OF_FACTORS)

        ! Local variables
        integer(ip) :: iw1, iw2

        if (n > 1) then

            ! Set wavetable index pointers
            iw1 = 1
            iw2 = n + 1

            call backward_lower_utility_routine(m, n, r, mdimr, &
                wsave(iw1:), wsave(iw2:))
        end if

    end subroutine hrfftb

    ! Purpose:
    !
    ! Factors of an integer for floating point computations.
    !
    pure subroutine compute_factorization(n, subtransforms, number_of_factors, integer_factors)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: subtransforms(:)
        integer(ip), intent(out) :: number_of_factors
        real(wp),    intent(out) :: integer_factors(:)

        ! Local variables
        integer(ip) :: nf, ntest, j, factor

        ! Initialize
        factor = 0
        ntest = n
        nf = 0
        j = 0

        select case(n)
            case(:0)
                error stop 'Length n must be a positive integer'
            case(1)
                integer_factors(1) = 1
                number_of_factors = 1
            case default

                block
                    integer(ip) :: factors(size(integer_factors))

                    do while (1 < ntest)

                        ! Increment j
                        j = j + 1

                        ! Choose factor
                        select case (j)
                            case(1:4) ! case(1:size(subtransforms))
                                factor = subtransforms(j)
                            case default
                                factor = factor + 2
                        end select

                        do while ((ntest - factor * (ntest/factor)) == 0)
                            nf = nf + 1
                            factors(nf + 2) = factor
                            ntest = ntest/factor
                            if (factor == 2 .and. nf /= 1) then
                                factors(nf+2:4:(-1)) = factors(nf+1:3:(-1))
                                factors(3) = 2
                            end if
                        end do
                    end do

                    factors(1) = n
                    factors(2) = nf
                    number_of_factors = nf
                    integer_factors = real(factors, kind=wp)
                end block
        end select

    end subroutine compute_factorization

    pure subroutine precompute_factorization_and_trig_lookup_table(n, trig_lookup_table, factors)

        ! Dummy arguments
        integer(ip), intent(in)  :: n
        real(wp),    intent(out) :: trig_lookup_table(:)
        real(wp),    intent(out) :: factors(:)

        ! Local variables
        integer(ip)            :: i, ido, ii, iip, ipm, iis
        integer(ip)            :: j, k1, l1, l2, ld
        integer(ip)            :: nf, nfm1
        integer(ip), parameter :: SUBTRANSFORMS(*) = [4, 2, 3, 5]
        real(wp)               :: theta, d_theta, mesh, product_1

        call compute_factorization(n, SUBTRANSFORMS, nf, factors)

        d_theta = TWO_PI/n
        iis = 0
        nfm1 = nf-1
        l1 = 1

        if (nfm1 /= 0) then
            do k1=1, nfm1
                iip = int(factors(k1+2), kind=ip)
                ld = 0
                l2 = l1*iip
                ido = n/l2
                ipm = iip-1
                do j=1, ipm
                    ld = ld+l1
                    i = iis
                    mesh = real(ld, kind=wp) * d_theta
                    product_1 = ZERO
                    do ii=3, ido, 2
                        i = i+2
                        product_1 = product_1 + ONE
                        theta = product_1 * mesh
                        trig_lookup_table(i-1) = cos(theta)
                        trig_lookup_table(i) = sin(theta)
                    end do
                    iis = iis+ido
                end do
                l1 = l2
            end do
        end if

    end subroutine precompute_factorization_and_trig_lookup_table

    subroutine forward_lower_utility_routine(m, n, c, mdimc, wa, fac)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        real(wp),    intent(inout)  :: c(:,:)
        integer(ip), intent(in)     :: mdimc
        real(wp),    intent(in)     :: wa(:)
        real(wp),    intent(in)     :: fac(:)

        ! Local variables
        integer(ip) :: k1, n1, n2
        integer(ip) :: na, kh, nf, iip
        integer(ip) :: iw1, iw2, iw3, iw4, ido, idl1

        nf = int(fac(2), kind=ip)
        na = 1
        n2 = n
        iw1 = n

        block
            real(wp) :: ch(m,n)

            do k1=1, nf
                kh = nf-k1
                iip = int(fac(kh+3), kind=ip)
                n1 = n2/iip
                ido = n/n2
                idl1 = ido*n1
                iw1 = iw1-(iip-1)*ido
                na = 1-na

                select case (iip)
                    case (2)
                        if (na == 0) then
                            call forward_pass_2(m, ido, n1, c, mdimc, ch, m, wa(iw1:))
                        else
                            call forward_pass_2(m, ido, n1, ch, m, c, mdimc, wa(iw1:))
                        end if
                    case (3)
                        iw2 = iw1+ido
                        if (na == 0) then
                            call forward_pass_3(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:))
                        else
                            call forward_pass_3(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:))
                        end if
                    case(4)
                        iw2 = iw1+ido
                        iw3 = iw2+ido
                        if (na == 0) then
                            call forward_pass_4(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:), wa(iw3:))
                        else
                            call forward_pass_4(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:), wa(iw3:))
                        end if
                    case (5)
                        iw2 = iw1+ido
                        iw3 = iw2+ido
                        iw4 = iw3+ido
                        if (na == 0) then
                            call forward_pass_5(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:), wa(iw3:), wa(iw4:))
                        else
                            call forward_pass_5(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:), wa(iw3:), wa(iw4:))
                        end if
                    case default
                        if (ido == 1) na = 1-na
                        if (na == 0) then
                            call forward_pass_n(m, ido, iip, n1, idl1, c, c, c, mdimc, ch, ch, m, wa(iw1:))
                            na = 1
                        else
                            call forward_pass_n(m, ido, iip, n1, idl1, ch, ch, ch, m, c, c, mdimc, wa(iw1:))
                            na = 0
                        end if
                end select
                n2 = n1
            end do

            if (na /= 1) c(:m, :n) = ch
        end block

    end subroutine forward_lower_utility_routine

    subroutine forward_pass_2(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: ch(mdimch, ido, 2, l1)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(inout)  :: cc(mdimcc, ido, l1, 2)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(in)     :: wa1(:)

        ! Local variables
        integer(ip) :: i, k, m, ic, idp2

        ch(:mp, 1, 1, :) = cc(:mp, 1, :, 1)+cc(:mp, 1, :, 2)
        ch(:mp, ido, 2, :) = cc(:mp, 1, :, 1)-cc(:mp, 1, :, 2)

        if (ido < 2) then
            return
        else if (ido /= 2) then
            idp2 = ido+2
            do k=1, l1
                do i=3, ido, 2
                    ic = idp2-i
                    do m=1, mp
                        ch(m, i, 1, k) = &
                            cc(m, i, k, 1)+(wa1(i-2)*cc(m, i, k, 2)- &
                            wa1(i-1)*cc(m, i-1, k, 2))

                        ch(m, ic, 2, k) = &
                            (wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &
                            cc(m, i-1, k, 2))-cc(m, i, k, 1)

                        ch(m, i-1, 1, k) = &
                            cc(m, i-1, k, 1)+(wa1(i-2)*cc(m, i-1, k, 2)+ &          !
                            wa1(i-1)*cc(m, i, k, 2))

                        ch(m, ic-1, 2, k) = &
                            cc(m, i-1, k, 1)-(wa1(i-2)*cc(m, i-1, k, 2)+ &         !
                            wa1(i-1)*cc(m, i, k, 2))
                    end do
                end do
            end do
            if (odd(ido)) return
        end if

        ch(:mp, 1, 2, :) = -cc(:mp, ido, :, 2)
        ch(:mp, ido, 1, :) = cc(:mp, ido, :, 1)

    end subroutine forward_pass_2

    subroutine forward_pass_3(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1, wa2)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: ch(mdimch, ido, 3, l1)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(inout)  :: cc(mdimcc, ido, l1, 3)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)

        ! Local variables
        integer(ip)         :: i, k, m, ic, idp2
        real(wp), parameter :: ARG=TWO_PI/3
        real(wp), parameter :: TAUR = cos(ARG)
        real(wp), parameter :: TAUI = sin(ARG)

        do k=1, l1
            do m=1, mp
                ch(m, 1, 1, k) = &
                    cc(m, 1, k, 1)+(cc(m, 1, k, 2)+cc(m, 1, k, 3))

                ch(m, 1, 3, k) = &
                    TAUI*(cc(m, 1, k, 3)-cc(m, 1, k, 2))

                ch(m, ido, 2, k) = &
                    cc(m, 1, k, 1)+TAUR* &
                    (cc(m, 1, k, 2)+cc(m, 1, k, 3))
            end do
        end do

        if (ido == 1) return

        idp2 = ido+2
        do k=1, l1
            do i=3, ido, 2
                ic = idp2-i
                do m=1, mp

                    ch(m, i-1, 1, k) = &
                        cc(m, i-1, k, 1)+((wa1(i-2)*cc(m, i-1, k, 2)+ &         !
                        wa1(i-1)*cc(m, i, k, 2))+(wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &        !
                        cc(m, i, k, 3)))

                    ch(m, i, 1, k) = &
                        cc(m, i, k, 1)+((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &      !
                        cc(m, i-1, k, 2))+(wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &
                        cc(m, i-1, k, 3)))

                    ch(m, i-1, 3, k) = &
                        (cc(m, i-1, k, 1)+TAUR*((wa1(i-2)* &
                        cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2))+(wa2(i-2)* &
                        cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3))))+(TAUI*((wa1(i-2)* &        !
                        cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2))-(wa2(i-2)* &
                        cc(m, i, k, 3)-wa2(i-1)*cc(m, i-1, k, 3))))

                    ch(m, ic-1, 2, k) = &
                        (cc(m, i-1, k, 1)+TAUR*((wa1(i-2)* &
                        cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2))+(wa2(i-2)* &
                        cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3))))-(TAUI*((wa1(i-2)* &
                        cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2))-(wa2(i-2)* &
                        cc(m, i, k, 3)-wa2(i-1)*cc(m, i-1, k, 3))))

                    ch(m, i, 3, k) = &
                        (cc(m, i, k, 1)+TAUR*((wa1(i-2)*cc(m, i, k, 2)- &
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &
                        cc(m, i-1, k, 3))))+(TAUI*((wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                        cc(m, i, k, 2))))

                    ch(m, ic, 2, k) = &
                        (TAUI*((wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                        cc(m, i, k, 2))))-(cc(m, i, k, 1)+TAUR*((wa1(i-2)*cc(m, i, k, 2)- &
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &
                        cc(m, i-1, k, 3))))
                end do
            end do
        end do

    end subroutine forward_pass_3

    subroutine forward_pass_4(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1, wa2, wa3)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, l1, 4)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(inout)  :: ch(mdimch, ido, 4, l1)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)
        real(wp),    intent(in)     :: wa3(:)

        ! Local variables
        integer(ip)         :: i, k, m, ic, idp2
        real(wp), parameter :: HALF_SQRT_2 = SQRT_2/2

        do k=1, l1
            do m=1, mp
                ch(m, 1, 1, k) = &
                    (cc(m, 1, k, 2)+cc(m, 1, k, 4)) &
                    +(cc(m, 1, k, 1) + cc(m, 1, k, 3))
                ch(m, ido, 4, k) = &
                    (cc(m, 1, k, 1)+cc(m, 1, k, 3)) &
                    -(cc(m, 1, k, 2) + cc(m, 1, k, 4))
                ch(m, ido, 2, k) = &
                    cc(m, 1, k, 1)-cc(m, 1, k, 3)
                ch(m, 1, 3, k) = &
                    cc(m, 1, k, 4)-cc(m, 1, k, 2)
            end do
        end do

        if (ido < 2) then
            return
        else if (ido /= 2) then
            idp2 = ido+2
            do k=1, l1
                do i=3, ido, 2
                    ic = idp2-i
                    do m=1, mp

                        ch(m, i-1, 1, k) = &
                            ((wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &              !
                            cc(m, i, k, 2))+(wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &
                            cc(m, i, k, 4)))+(cc(m, i-1, k, 1)+(wa2(i-2)*cc(m, i-1, k, 3)+ &          !
                            wa2(i-1)*cc(m, i, k, 3)))

                        ch(m, ic-1, 4, k) = &
                            (cc(m, i-1, k, 1)+(wa2(i-2)*cc(m, i-1, k, 3)+ &        !
                            wa2(i-1)*cc(m, i, k, 3)))-((wa1(i-2)*cc(m, i-1, k, 2)+ &               !
                            wa1(i-1)*cc(m, i, k, 2))+(wa3(i-2)*cc(m, i-1, k, 4)+ &
                            wa3(i-1)*cc(m, i, k, 4)))

                        ch(m, i, 1, k) = &
                            ((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &
                            cc(m, i-1, k, 2))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                            cc(m, i-1, k, 4)))+(cc(m, i, k, 1)+(wa2(i-2)*cc(m, i, k, 3)- &            !
                            wa2(i-1)*cc(m, i-1, k, 3)))

                        ch(m, ic, 4, k) = &
                            ((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &
                            cc(m, i-1, k, 2))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                            cc(m, i-1, k, 4)))-(cc(m, i, k, 1)+(wa2(i-2)*cc(m, i, k, 3)- &            !
                            wa2(i-1)*cc(m, i-1, k, 3)))

                        ch(m, i-1, 3, k) = &
                            ((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &
                            cc(m, i-1, k, 2))-(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                            cc(m, i-1, k, 4)))+(cc(m, i-1, k, 1)-(wa2(i-2)*cc(m, i-1, k, 3)+ &        !
                            wa2(i-1)*cc(m, i, k, 3)))

                        ch(m, ic-1, 2, k) = &
                            (cc(m, i-1, k, 1)-(wa2(i-2)*cc(m, i-1, k, 3)+ &        !
                            wa2(i-1)*cc(m, i, k, 3)))-((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &        !
                            cc(m, i-1, k, 2))-(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                            cc(m, i-1, k, 4)))

                        ch(m, i, 3, k) = &
                            ((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &
                            cc(m, i, k, 4))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                            cc(m, i, k, 2)))+(cc(m, i, k, 1)-(wa2(i-2)*cc(m, i, k, 3)- &              !
                            wa2(i-1)*cc(m, i-1, k, 3)))

                        ch(m, ic, 2, k) = &
                            ((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &               !
                            cc(m, i, k, 4))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                            cc(m, i, k, 2)))-(cc(m, i, k, 1)-(wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &     !
                            cc(m, i-1, k, 3)))
                    end do
                end do
            end do

            if (odd(ido)) return

        end if

        do k=1, l1
            do m=1, mp

                ch(m, ido, 1, k) = &
                    (HALF_SQRT_2*(cc(m, ido, k, 2)-cc(m, ido, k, 4)))+ &
                    cc(m, ido, k, 1)

                ch(m, ido, 3, k) = &
                    cc(m, ido, k, 1)-(HALF_SQRT_2*(cc(m, ido, k, 2)- &
                    cc(m, ido, k, 4)))

                ch(m, 1, 2, k) = &
                    (-HALF_SQRT_2*(cc(m, ido, k, 2)+cc(m, ido, k, 4)))- &
                    cc(m, ido, k, 3)

                ch(m, 1, 4, k) = &
                    (-HALF_SQRT_2*(cc(m, ido, k, 2)+cc(m, ido, k, 4)))+ &
                    cc(m, ido, k, 3)
            end do
        end do

    end subroutine forward_pass_4

    subroutine forward_pass_5(mp, ido, l1, cc, mdimcc, ch, mdimch, &
        wa1, wa2, wa3, wa4)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: ch(mdimch, ido, 5, l1)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(inout)  :: cc(mdimcc, ido, l1, 5)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)
        real(wp),    intent(in)     :: wa3(:)
        real(wp),    intent(in)     :: wa4(:)

        ! Local variables
        integer(ip)         :: i, k, m, ic, idp2
        real(wp), parameter :: ARG = TWO_PI/5
        real(wp), parameter :: TR11=cos(ARG)
        real(wp), parameter :: TI11=sin(ARG)
        real(wp), parameter :: TR12=cos(TWO*ARG)
        real(wp), parameter :: TI12=sin(TWO*ARG)

        do k=1, l1
            do m=1, mp

                ch(m, 1, 1, k) = &
                    cc(m, 1, k, 1)+(cc(m, 1, k, 5)+cc(m, 1, k, 2))+ &
                    (cc(m, 1, k, 4)+cc(m, 1, k, 3))

                ch(m, ido, 2, k) = &
                    cc(m, 1, k, 1)+TR11*(cc(m, 1, k, 5)+cc(m, 1, k, 2))+ &
                    TR12*(cc(m, 1, k, 4)+cc(m, 1, k, 3))

                ch(m, 1, 3, k) = &
                    TI11*(cc(m, 1, k, 5)-cc(m, 1, k, 2))+TI12* &
                    (cc(m, 1, k, 4)-cc(m, 1, k, 3))

                ch(m, ido, 4, k) = &
                    cc(m, 1, k, 1)+TR12*(cc(m, 1, k, 5)+cc(m, 1, k, 2))+ &        !
                    TR11*(cc(m, 1, k, 4)+cc(m, 1, k, 3))

                ch(m, 1, 5, k) = &
                    TI12*(cc(m, 1, k, 5)-cc(m, 1, k, 2))-TI11* &
                    (cc(m, 1, k, 4)-cc(m, 1, k, 3))
            end do
        end do

        if (ido == 1) return

        idp2 = ido+2
        do k=1, l1
            do i=3, ido, 2
                ic = idp2-i
                do m=1, mp

                    ch(m, i-1, 1, k) = &
                        cc(m, i-1, k, 1)+((wa1(i-2)*cc(m, i-1, k, 2)+ &         !
                        wa1(i-1)*cc(m, i, k, 2))+(wa4(i-2)*cc(m, i-1, k, 5)+wa4(i-1)* &        !
                        cc(m, i, k, 5)))+((wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &               !
                        cc(m, i, k, 3))+(wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)*cc(m, i, k, 4)))      !

                    ch(m, i, 1, k) = &
                        cc(m, i, k, 1)+((wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)* &      !
                        cc(m, i-1, k, 2))+(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)* &
                        cc(m, i-1, k, 5)))+((wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &               !
                        cc(m, i-1, k, 3))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4)))

                    ch(m, i-1, 3, k) = &
                        cc(m, i-1, k, 1)+TR11* &
                        ( wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2) &
                        +wa4(i-2)*cc(m, i-1, k, 5)+wa4(i-1)*cc(m, i, k, 5))+TR12* &            !
                        ( wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3) &
                        +wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)*cc(m, i, k, 4))+TI11* &            !
                        ( wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2) &
                        -(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)*cc(m, i-1, k, 5)))+TI12* &          !
                        ( wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)*cc(m, i-1, k, 3) &
                        -(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)*cc(m, i-1, k, 4)))

                    ch(m, ic-1, 2, k) = &
                        cc(m, i-1, k, 1)+TR11* &
                        ( wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2) &
                        +wa4(i-2)*cc(m, i-1, k, 5)+wa4(i-1)*cc(m, i, k, 5))+TR12* &            !
                        ( wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3) &
                        +wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)*cc(m, i, k, 4))-(TI11* &            !
                        ( wa1(i-2)*cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2) &
                        -(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)*cc(m, i-1, k, 5)))+TI12* &          !
                        ( wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)*cc(m, i-1, k, 3) &
                        -(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)*cc(m, i-1, k, 4))))                 !

                    ch(m, i, 3, k) = &
                        (cc(m, i, k, 1)+TR11*((wa1(i-2)*cc(m, i, k, 2)- &         !
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)* &        !
                        cc(m, i-1, k, 5)))+TR12*((wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &          !
                        cc(m, i-1, k, 3))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4))))+(TI11*((wa4(i-2)*cc(m, i-1, k, 5)+ &               !
                        wa4(i-1)*cc(m, i, k, 5))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &        !
                        cc(m, i, k, 2)))+TI12*((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &          !
                        cc(m, i, k, 4))-(wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))))

                    ch(m, ic, 2, k) = &
                        (TI11*((wa4(i-2)*cc(m, i-1, k, 5)+wa4(i-1)* &         !
                        cc(m, i, k, 5))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                        cc(m, i, k, 2)))+TI12*((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &          !
                        cc(m, i, k, 4))-(wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))))-(cc(m, i, k, 1)+TR11*((wa1(i-2)*cc(m, i, k, 2)- &       !
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)* &        !
                        cc(m, i-1, k, 5)))+TR12*((wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &          !
                        cc(m, i-1, k, 3))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4))))

                    ch(m, i-1, 5, k) = &
                        (cc(m, i-1, k, 1)+TR12*((wa1(i-2)* &
                        cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2))+(wa4(i-2)* &
                        cc(m, i-1, k, 5)+wa4(i-1)*cc(m, i, k, 5)))+TR11*((wa2(i-2)* &          !
                        cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3))+(wa3(i-2)* &
                        cc(m, i-1, k, 4)+wa3(i-1)*cc(m, i, k, 4))))+(TI12*((wa1(i-2)* &        !
                        cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2))-(wa4(i-2)*cc(m, i, k, 5)- &     !
                        wa4(i-1)*cc(m, i-1, k, 5)))-TI11*((wa2(i-2)*cc(m, i, k, 3)- &          !
                        wa2(i-1)*cc(m, i-1, k, 3))-(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &        !
                        cc(m, i-1, k, 4))))

                    ch(m, ic-1, 4, k) = &
                        (cc(m, i-1, k, 1)+TR12*((wa1(i-2)* &
                        cc(m, i-1, k, 2)+wa1(i-1)*cc(m, i, k, 2))+(wa4(i-2)* &
                        cc(m, i-1, k, 5)+wa4(i-1)*cc(m, i, k, 5)))+TR11*((wa2(i-2)* &
                        cc(m, i-1, k, 3)+wa2(i-1)*cc(m, i, k, 3))+(wa3(i-2)* &
                        cc(m, i-1, k, 4)+wa3(i-1)*cc(m, i, k, 4))))-(TI12*((wa1(i-2)* &
                        cc(m, i, k, 2)-wa1(i-1)*cc(m, i-1, k, 2))-(wa4(i-2)*cc(m, i, k, 5)- &
                        wa4(i-1)*cc(m, i-1, k, 5)))-TI11*((wa2(i-2)*cc(m, i, k, 3)- &
                        wa2(i-1)*cc(m, i-1, k, 3))-(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4))))

                    ch(m, i, 5, k) = &
                        (cc(m, i, k, 1)+TR12*((wa1(i-2)*cc(m, i, k, 2)- &
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)* &
                        cc(m, i-1, k, 5)))+TR11*((wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &
                        cc(m, i-1, k, 3))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4))))+(TI12*((wa4(i-2)*cc(m, i-1, k, 5)+ &
                        wa4(i-1)*cc(m, i, k, 5))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                        cc(m, i, k, 2)))-TI11*((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &
                        cc(m, i, k, 4))-(wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))))

                    ch(m, ic, 4, k) = &
                        (TI12*((wa4(i-2)*cc(m, i-1, k, 5)+wa4(i-1)* &
                        cc(m, i, k, 5))-(wa1(i-2)*cc(m, i-1, k, 2)+wa1(i-1)* &
                        cc(m, i, k, 2)))-TI11*((wa3(i-2)*cc(m, i-1, k, 4)+wa3(i-1)* &
                        cc(m, i, k, 4))-(wa2(i-2)*cc(m, i-1, k, 3)+wa2(i-1)* &
                        cc(m, i, k, 3))))-(cc(m, i, k, 1)+TR12*((wa1(i-2)*cc(m, i, k, 2)- &
                        wa1(i-1)*cc(m, i-1, k, 2))+(wa4(i-2)*cc(m, i, k, 5)-wa4(i-1)* &
                        cc(m, i-1, k, 5)))+TR11*((wa2(i-2)*cc(m, i, k, 3)-wa2(i-1)* &
                        cc(m, i-1, k, 3))+(wa3(i-2)*cc(m, i, k, 4)-wa3(i-1)* &
                        cc(m, i-1, k, 4))))
                end do
            end do
        end do

    end subroutine forward_pass_5

    subroutine forward_pass_n(mp, ido, iip, l1, idl1, cc, c1, c2, mdimcc, &
        ch, ch2, mdimch, wa)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: iip
        integer(ip), intent(in)     :: l1
        integer(ip), intent(in)     :: idl1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, iip, l1)
        real(wp),    intent(inout)  :: c1(mdimcc, ido, l1, iip)
        real(wp),    intent(inout)  :: c2(mdimcc, idl1, iip)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(inout)  :: ch(mdimch, ido, l1, iip)
        real(wp),    intent(inout)  :: ch2(mdimch, idl1, iip)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa(:)

        ! Local variables
        integer(ip) :: i, j, k, l, j2, ic, jc, lc, ik, iis, idij
        real(wp)    :: dc2, ai1, ai2, ar1, ar2, ds2
        real(wp)    :: ar1h, ar2h

        associate (&
            ipph => (iip+1)/2, &
            ipp2 => iip+2, &
            idp2 => ido+2, &
            nbd => (ido-1)/2, &
            arg => TWO_PI/iip &
            )
            associate (&
                dcp => cos(arg), &
                dsp => sin(arg) &
                )

                if (ido /= 1) then
                    ch2(:mp, :idl1, 1) = c2(:mp, :idl1, 1)
                    ch(:mp, 1, :l1, 2:iip) = c1(:mp, 1, :l1, 2:iip)

                    if (nbd <= l1) then
                        iis = -ido
                        do j=2, iip
                            iis = iis+ido
                            idij = iis
                            do i=3, ido, 2
                                ch(:mp, i-1, :l1, j) = wa(idij+1)*c1(:mp, i-1, :l1, j)+wa(idij+2) &            !
                                    *c1(:mp, i, :l1, j)
                                ch(:mp, i, :l1, j) = wa(idij+1)*c1(:mp, i, :l1, j)-wa(idij+2) &
                                    *c1(:mp, i-1, :l1, j)
                            end do
                        end do
                    else
                        iis = -ido
                        do j=2, iip
                            iis = iis+ido
                            do k=1, l1
                                idij = iis
                                do i=3, ido, 2
                                    idij = idij+2
                                    ch(:mp, i-1, k, j) = wa(idij-1)*c1(:mp, i-1, k, j)+wa(idij) &            !
                                        *c1(:mp, i, k, j)
                                    ch(:mp, i, k, j) = wa(idij-1)*c1(:mp, i, k, j)-wa(idij) &
                                        *c1(:mp, i-1, k, j)
                                end do
                            end do
                        end do
                    end if
                    if (l1 <= nbd) then
                        do j=2, ipph
                            jc = ipp2-j
                            do k=1, l1
                                do i=3, ido, 2
                                    c1(:mp, i-1, k, j) = ch(:mp, i-1, k, j)+ch(:mp, i-1, k, jc)
                                    c1(:mp, i-1, k, jc) = ch(:mp, i, k, j)-ch(:mp, i, k, jc)
                                    c1(:mp, i, k, j) = ch(:mp, i, k, j)+ch(:mp, i, k, jc)
                                    c1(:mp, i, k, jc) = ch(:mp, i-1, k, jc)-ch(:mp, i-1, k, j)
                                end do
                            end do
                        end do
                    else
                        do j=2, ipph
                            jc = ipp2-j
                            do i=3, ido, 2
                                c1(:mp, i-1, :l1, j) = ch(:mp, i-1, :l1, j)+ch(:mp, i-1, :l1, jc)
                                c1(:mp, i-1, :l1, jc) = ch(:mp, i, :l1, j)-ch(:mp, i, :l1, jc)
                                c1(:mp, i, :l1, j) = ch(:mp, i, :l1, j)+ch(:mp, i, :l1, jc)
                                c1(:mp, i, :l1, jc) = ch(:mp, i-1, :l1, jc)-ch(:mp, i-1, :l1, j)
                            end do
                        end do
                    end if
                else
                    c2(:mp, :idl1, 1) = ch2(:mp, :idl1, 1)
                end if

                do j=2, ipph
                    jc = ipp2-j
                    c1(:mp, 1, :l1, j) = ch(:mp, 1, :l1, j)+ch(:mp, 1, :l1, jc)
                    c1(:mp, 1, :l1, jc) = ch(:mp, 1, :l1, jc)-ch(:mp, 1, :l1, j)
                end do

                ar1 = ONE
                ai1 = ZERO
                do l=2, ipph
                    lc = ipp2-l
                    ar1h = dcp*ar1-dsp*ai1
                    ai1 = dcp*ai1+dsp*ar1
                    ar1 = ar1h
                    ch2(:mp, :idl1, l) = c2(:mp, :idl1, 1)+ar1*c2(:mp, :idl1, 2)
                    ch2(:mp, :idl1, lc) = ai1*c2(:mp, :idl1, iip)
                    dc2 = ar1
                    ds2 = ai1
                    ar2 = ar1
                    ai2 = ai1
                    do j=3, ipph
                        jc = ipp2-j
                        ar2h = dc2*ar2-ds2*ai2
                        ai2 = dc2*ai2+ds2*ar2
                        ar2 = ar2h
                        ch2(:mp, :idl1, l) = ch2(:mp, :idl1, l)+ar2*c2(:mp, :idl1, j)
                        ch2(:mp, :idl1, lc) = ch2(:mp, :idl1, lc)+ai2*c2(:mp, :idl1, jc)
                    end do
                end do

                do j=2, ipph
                    do ik=1, idl1
                        ch2(:mp, ik, 1) = ch2(:mp, ik, 1)+c2(:mp, ik, j)
                    end do
                end do

                if (ido >= l1) then
                    cc(:mp, :ido, 1, :l1) = ch(:mp, :ido, :l1, 1)
                else
                    cc(:mp, :ido, 1, :l1) = ch(:mp, :ido, :l1, 1)
                end if

                do j=2, ipph
                    jc = ipp2-j
                    j2 = 2*j
                    cc(:mp, ido, j2-2, :l1) = ch(:mp, 1, :l1, j)
                    cc(:mp, 1, j2-1, :l1) = ch(:mp, 1, :l1, jc)
                end do

                if (ido == 1) return

                if (l1 <= nbd) then
                    do j=2, ipph
                        jc = ipp2-j
                        j2 = 2*j
                        do k=1, l1
                            do i=3, ido, 2
                                ic = idp2-i
                                cc(:mp, i-1, j2-1, k) = ch(:mp, i-1, k, j)+ch(:mp, i-1, k, jc)                !
                                cc(:mp, ic-1, j2-2, k) = ch(:mp, i-1, k, j)-ch(:mp, i-1, k, jc)               !
                                cc(:mp, i, j2-1, k) = ch(:mp, i, k, j)+ch(:mp, i, k, jc)
                                cc(:mp, ic, j2-2, k) = ch(:mp, i, k, jc)-ch(:mp, i, k, j)
                            end do
                        end do
                    end do
                else
                    do j=2, ipph
                        jc = ipp2-j
                        j2 = 2*j
                        do i=3, ido, 2
                            ic = idp2-i
                            cc(:mp, i-1, j2-1, :l1) = ch(:mp, i-1, :l1, j)+ch(:mp, i-1, :l1, jc)                !
                            cc(:mp, ic-1, j2-2, :l1) = ch(:mp, i-1, :l1, j)-ch(:mp, i-1, :l1, jc)               !
                            cc(:mp, i, j2-1, :l1) = ch(:mp, i, :l1, j)+ch(:mp, i, :l1, jc)
                            cc(:mp, ic, j2-2, :l1) = ch(:mp, i, :l1, jc)-ch(:mp, i, :l1, j)
                        end do
                    end do
                end if
            end associate
        end associate

    end subroutine forward_pass_n

    subroutine backward_lower_utility_routine(m, n, c, mdimc, wa, fac)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        real(wp),    intent(inout)  :: c(:,:)
        integer(ip), intent(in)     :: mdimc
        real(wp),    intent(in)     :: wa(:)
        real(wp),    intent(in)     :: fac(:)

        ! Local variables
        integer(ip) :: k1, n1, n2, na
        integer(ip) :: nf, iip, iw1, iw2, iw3, iw4, ido, idl1

        nf = int(fac(2), kind=ip)
        na = 0
        n1 = 1
        iw1 = 1

        block
            real(wp) :: ch(m,n)

            do k1=1, nf
                iip = int(fac(k1+2), kind=ip)
                n2 = iip*n1
                ido = n/n2
                idl1 = ido*n1

                select case (iip)
                    case (2)
                        if (na == 0) then
                            call backward_pass_2(m, ido, n1, c, mdimc, ch, m, wa(iw1:))
                        else
                            call backward_pass_2(m, ido, n1, ch, m, c, mdimc, wa(iw1:))
                        end if
                    case (3)
                        iw2 = iw1+ido
                        if (na == 0) then
                            call backward_pass_3(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:))
                        else
                            call backward_pass_3(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:))
                        end if
                    case (4)
                        iw2 = iw1+ido
                        iw3 = iw2+ido
                        if (na == 0) then
                            call backward_pass_4(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:), wa(iw3:))
                        else
                            call backward_pass_4(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:), wa(iw3:))
                        end if
                    case (5)
                        iw2 = iw1+ido
                        iw3 = iw2+ido
                        iw4 = iw3+ido
                        if (na == 0) then
                            call backward_pass_5(m, ido, n1, c, mdimc, ch, m, wa(iw1:), wa(iw2:), wa(iw3:), wa(iw4:))
                        else
                            call backward_pass_5(m, ido, n1, ch, m, c, mdimc, wa(iw1:), wa(iw2:), wa(iw3:), wa(iw4:))
                        end if
                    case default
                        if (na == 0) then
                            call backward_pass_n(m, ido, iip, n1, idl1, c, c, c, mdimc, ch, ch, m, wa(iw1:))
                        else
                            call backward_pass_n(m, ido, iip, n1, idl1, ch, ch, ch, m, c, c, mdimc, wa(iw1:))
                        end if
                        if (ido /= 1) na = 1-na
                end select
                na = 1-na
                n1 = n2
                iw1 = iw1+(iip-1)*ido
            end do

            if (na /= 0) c(:m, :n) = ch
        end block

    end subroutine backward_lower_utility_routine

    subroutine backward_pass_2(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, 2, l1)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(out)    :: ch(mdimch, ido, l1, 2)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa1(:)

        ! Local variables
        integer(ip) :: i, k, ic, idp2

        ch(:mp, 1, :, 1) = cc(:mp, 1, 1, :)+cc(:mp, ido, 2, :)
        ch(:mp, 1, :, 2) = cc(:mp, 1, 1, :)-cc(:mp, ido, 2, :)

        if (ido < 2) then
            return
        else if (ido /= 2) then
            idp2 = ido+2
            do k=1, l1
                do i=3, ido, 2
                    ic = idp2-i
                    ch(:mp, i-1, k, 1) = &
                        cc(:mp, i-1, 1, k)+cc(:mp, ic-1, 2, k)

                    ch(:mp, i, k, 1) = &
                        cc(:mp, i, 1, k)-cc(:mp, ic, 2, k)

                    ch(:mp, i-1, k, 2) = &
                        wa1(i-2)*(cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 2, k)) &         !
                        -wa1(i-1)*(cc(:mp, i, 1, k)+cc(:mp, ic, 2, k))

                    ch(:mp, i, k, 2) = &
                        wa1(i-2)*(cc(:mp, i, 1, k)+cc(:mp, ic, 2, k))+wa1(i-1) &      !
                        *(cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 2, k))
                end do
            end do
            if (odd(ido)) return
        end if

        ch(:mp, ido, :, 1) = cc(:mp, ido, 1, :)+cc(:mp, ido, 1, :)
        ch(:mp, ido, :, 2) = -(cc(:mp, 1, 2, :)+cc(:mp, 1, 2, :))

    end subroutine backward_pass_2

    subroutine backward_pass_3(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1, wa2)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, 3, l1)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(out)    :: ch(mdimch, ido, l1, 3)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)

        ! Local variables
        integer(ip)         :: i, k, ic, idp2
        real(wp), parameter :: ARG = TWO_PI/3
        real(wp), parameter :: TAUR = cos(ARG)
        real(wp), parameter :: TAUI = sin(ARG)

        ch(:mp, 1, :l1, 1) = &
            cc(:mp, 1, 1, :l1)+TWO * cc(:mp, ido, 2, :l1)

        ch(:mp, 1, :l1, 2) = &
            cc(:mp, 1, 1, :l1)+(TWO * TAUR)*cc(:mp, ido, 2, :l1) &
            -(TWO *TAUI)*cc(:mp, 1, 3, :l1)

        ch(:mp, 1, :l1, 3) = &
            cc(:mp, 1, 1, :l1)+(TWO * TAUR)*cc(:mp, ido, 2, :l1) &
            +TWO *TAUI*cc(:mp, 1, 3, :l1)

        if (ido == 1) return

        idp2 = ido+2
        do k=1, l1
            do i=3, ido, 2
                ic = idp2-i
                ch(:mp, i-1, k, 1) = &
                    cc(:mp, i-1, 1, k)+(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k))      !

                ch(:mp, i, k, 1) = &
                    cc(:mp, i, 1, k)+(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k))              !

                ch(:mp, i-1, k, 2) = &
                    wa1(i-2)* &
                    ((cc(:mp, i-1, 1, k)+TAUR*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)))- &
                    (TAUI*(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))) &
                    -wa1(i-1)* &
                    ((cc(:mp, i, 1, k)+TAUR*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))+ &
                    (TAUI*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))))

                ch(:mp, i, k, 2) = &
                    wa1(i-2)* &
                    ((cc(:mp, i, 1, k)+TAUR*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))+ &
                    (TAUI*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))) &
                    +wa1(i-1)* &
                    ((cc(:mp, i-1, 1, k)+TAUR*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)))- &
                    (TAUI*(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k))))

                ch(:mp, i-1, k, 3) = &
                    wa2(i-2)* &
                    ((cc(:mp, i-1, 1, k)+TAUR*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)))+ &
                    (TAUI*(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))) &
                    -wa2(i-1)* &
                    ((cc(:mp, i, 1, k)+TAUR*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))- &
                    (TAUI*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))))

                ch(:mp, i, k, 3) = &
                    wa2(i-2)* &
                    ((cc(:mp, i, 1, k)+TAUR*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))- &
                    (TAUI*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))) &
                    +wa2(i-1)* &
                    ((cc(:mp, i-1, 1, k)+TAUR*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)))+ &
                    (TAUI*(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k))))
            end do
        end do

    end subroutine backward_pass_3

    subroutine backward_pass_4(mp, ido, l1, cc, mdimcc, ch, mdimch, wa1, wa2, wa3)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, 4, l1)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(out)    :: ch(mdimch, ido, l1, 4)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)
        real(wp),    intent(in)     :: wa3(:)

        ! Local variables
        integer(ip)         :: i, k, ic, idp2
        real(wp), parameter :: SQRT2 = sqrt(TWO)

        ch(:mp, 1, :l1, 3) = (cc(:mp, 1, 1, :l1)+cc(:mp, ido, 4, :l1)) &
            -(cc(:mp, ido, 2, :l1)+cc(:mp, ido, 2, :l1))
        ch(:mp, 1, :l1, 1) = (cc(:mp, 1, 1, :l1)+cc(:mp, ido, 4, :l1)) &
            +(cc(:mp, ido, 2, :l1)+cc(:mp, ido, 2, :l1))
        ch(:mp, 1, :l1, 4) = (cc(:mp, 1, 1, :l1)-cc(:mp, ido, 4, :l1)) &
            +(cc(:mp, 1, 3, :l1)+cc(:mp, 1, 3, :l1))
        ch(:mp, 1, :l1, 2) = (cc(:mp, 1, 1, :l1)-cc(:mp, ido, 4, :l1)) &
            -(cc(:mp, 1, 3, :l1)+cc(:mp, 1, 3, :l1))

        if (ido < 2) then
            return
        else if (ido /= 2) then
            idp2 = ido+2
            do k=1, l1
                do i=3, ido, 2
                    ic = idp2-i
                    ch(:mp, i-1, k, 1) = &
                        (cc(:mp, i-1, 1, k)+cc(:mp, ic-1, 4, k)) &
                        +(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k))

                    ch(:mp, i, k, 1) = &
                        (cc(:mp, i, 1, k)-cc(:mp, ic, 4, k)) &
                        +(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k))

                    ch(:mp, i-1, k, 2) = &
                        wa1(i-2)*((cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 4, k)) &          !
                        -(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))-wa1(i-1) &
                        *((cc(:mp, i, 1, k)+cc(:mp, ic, 4, k))+(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))      !

                    ch(:mp, i, k, 2)= &
                        wa1(i-2)*((cc(:mp, i, 1, k)+cc(:mp, ic, 4, k)) &
                        +(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))+wa1(i-1) &
                        *((cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 4, k))-(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))      !

                    ch(:mp, i-1, k, 3) = &
                        wa2(i-2)*((cc(:mp, i-1, 1, k)+cc(:mp, ic-1, 4, k)) &          !
                        -(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)))-wa2(i-1) &
                        *((cc(:mp, i, 1, k)-cc(:mp, ic, 4, k))-(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))          !

                    ch(:mp, i, k, 3) = &
                        wa2(i-2)*((cc(:mp, i, 1, k)-cc(:mp, ic, 4, k)) &
                        -(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)))+wa2(i-1) &
                        *((cc(:mp, i-1, 1, k)+cc(:mp, ic-1, 4, k))-(cc(:mp, i-1, 3, k) &
                        +cc(:mp, ic-1, 2, k)))

                    ch(:mp, i-1, k, 4) = &
                        wa3(i-2)*((cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 4, k)) &          !
                        +(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))-wa3(i-1) &
                        *((cc(:mp, i, 1, k)+cc(:mp, ic, 4, k))-(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))       !

                    ch(:mp, i, k, 4) = &
                        wa3(i-2)*((cc(:mp, i, 1, k)+cc(:mp, ic, 4, k)) &
                        -(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k)))+wa3(i-1) &
                        *((cc(:mp, i-1, 1, k)-cc(:mp, ic-1, 4, k))+(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k)))      !
                end do
            end do
            if (odd(ido)) return
        end if

        ch(:mp, ido, :l1, 1) = &
            (cc(:mp, ido, 1, :l1)+cc(:mp, ido, 3, :l1)) &
            +(cc(:mp, ido, 1, :l1)+cc(:mp, ido, 3, :l1))

        ch(:mp, ido, :l1, 2) = &
            SQRT2*((cc(:mp, ido, 1, :l1)-cc(:mp, ido, 3, :l1)) &
            -(cc(:mp, 1, 2, :l1)+cc(:mp, 1, 4, :l1)))

        ch(:mp, ido, :l1, 3) = &
            (cc(:mp, 1, 4, :l1)-cc(:mp, 1, 2, :l1)) &
            +(cc(:mp, 1, 4, :l1)-cc(:mp, 1, 2, :l1))

        ch(:mp, ido, :l1, 4) = &
            -SQRT2*((cc(:mp, ido, 1, :l1)-cc(:mp, ido, 3, :l1)) &
            +(cc(:mp, 1, 2, :l1)+cc(:mp, 1, 4, :l1)))

    end subroutine backward_pass_4

    subroutine backward_pass_5(mp, ido, l1, cc, mdimcc, ch, mdimch, &
        wa1, wa2, wa3, wa4)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: l1
        real(wp),    intent(out)    :: ch(mdimch, ido, l1, 5)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(inout)  :: cc(mdimcc, ido, 5, l1)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(in)     :: wa1(:)
        real(wp),    intent(in)     :: wa2(:)
        real(wp),    intent(in)     :: wa3(:)
        real(wp),    intent(in)     :: wa4(:)

        ! Local variables
        integer(ip)         :: i, k, ic, idp2
        real(wp), parameter :: ARG = TWO_PI/5
        real(wp), parameter :: TR11 = cos(ARG)
        real(wp), parameter :: TI11 = sin(ARG)
        real(wp), parameter :: TR12 = cos(TWO * ARG)
        real(wp), parameter :: TI12 = sin(TWO * ARG)

        do k=1, l1
            ch(:mp, 1, k, 1) = &
                cc(:mp, 1, 1, k)+TWO *cc(:mp, ido, 2, k)+TWO *cc(:mp, ido, 4, k)          !

            ch(:mp, 1, k, 2) = &
                (cc(:mp, 1, 1, k)+TR11*TWO *cc(:mp, ido, 2, k) &
                +TR12*TWO *cc(:mp, ido, 4, k))-(TI11*TWO *cc(:mp, 1, 3, k) &
                +TI12*TWO *cc(:mp, 1, 5, k))

            ch(:mp, 1, k, 3) = &
                (cc(:mp, 1, 1, k)+TR12*TWO *cc(:mp, ido, 2, k) &
                +TR11*TWO *cc(:mp, ido, 4, k))-(TI12*TWO *cc(:mp, 1, 3, k) &
                -TI11*TWO *cc(:mp, 1, 5, k))

            ch(:mp, 1, k, 4) = &
                (cc(:mp, 1, 1, k)+TR12*TWO *cc(:mp, ido, 2, k) &
                +TR11*TWO *cc(:mp, ido, 4, k))+(TI12*TWO *cc(:mp, 1, 3, k) &
                -TI11*TWO *cc(:mp, 1, 5, k))

            ch(:mp, 1, k, 5) = &
                (cc(:mp, 1, 1, k)+TR11*TWO *cc(:mp, ido, 2, k) &
                +TR12*TWO *cc(:mp, ido, 4, k))+(TI11*TWO *cc(:mp, 1, 3, k) &
                +TI12*TWO *cc(:mp, 1, 5, k))
        end do

        if (ido == 1) return

        idp2 = ido+2

        do k=1, l1
            do i=3, ido, 2
                ic = idp2-i
                ch(:mp, i-1, k, 1) = &
                    cc(:mp, i-1, 1, k)+(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k))

                ch(:mp, i, k, 1) = &
                    cc(:mp, i, 1, k)+(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)) &
                    +(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))

                ch(:mp, i-1, k, 2) = &
                    wa1(i-2)*((cc(:mp, i-1, 1, k)+TR11* &
                    (cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k))+TR12 &
                    *(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))-(TI11*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))+TI12*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k)))) &
                    -wa1(i-1)*((cc(:mp, i, 1, k)+TR11*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)) &
                    +TR12*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k)))+(TI11*(cc(:mp, i-1, 3, k) &
                    -cc(:mp, ic-1, 2, k))+TI12*(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k))))

                ch(:mp, i, k, 2) = &
                    wa1(i-2)*((cc(:mp, i, 1, k)+TR11*(cc(:mp, i, 3, k) &          !
                    -cc(:mp, ic, 2, k))+TR12*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))) &
                    +(TI11*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))+TI12 &
                    *(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k))))+wa1(i-1) &
                    *((cc(:mp, i-1, 1, k)+TR11*(cc(:mp, i-1, 3, k) &
                    +cc(:mp, ic-1, 2, k))+TR12*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k))) &
                    -(TI11*(cc(:mp, i, 3, k)+cc(:mp, ic, 2, k))+TI12 &
                    *(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k))))

                ch(:mp, i-1, k, 3) = &
                    wa2(i-2) &
                    *((cc(:mp, i-1, 1, k)+TR12*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR11*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))-(TI12*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))-TI11*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k)))) &
                    -wa2(i-1) &
                    *((cc(:mp, i, 1, k)+TR12*(cc(:mp, i, 3, k)- &
                    cc(:mp, ic, 2, k))+TR11*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))) &
                    +(TI12*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))-TI11 &
                    *(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k))))

                ch(:mp, i, k, 3) = &
                    wa2(i-2) &
                    *((cc(:mp, i, 1, k)+TR12*(cc(:mp, i, 3, k)- &
                    cc(:mp, ic, 2, k))+TR11*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))) &
                    +(TI12*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))-TI11 &
                    *(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k)))) &
                    +wa2(i-1) &
                    *((cc(:mp, i-1, 1, k)+TR12*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR11*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))-(TI12*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))-TI11*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k))))

                ch(:mp, i-1, k, 4) = &
                    wa3(i-2) &
                    *((cc(:mp, i-1, 1, k)+TR12*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR11*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))+(TI12*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))-TI11*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k)))) &
                    -wa3(i-1) &
                    *((cc(:mp, i, 1, k)+TR12*(cc(:mp, i, 3, k)- &
                    cc(:mp, ic, 2, k))+TR11*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))) &
                    -(TI12*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))-TI11 &
                    *(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k))))

                ch(:mp, i, k, 4) = &
                    wa3(i-2) &
                    *((cc(:mp, i, 1, k)+TR12*(cc(:mp, i, 3, k)- &
                    cc(:mp, ic, 2, k))+TR11*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k))) &
                    -(TI12*(cc(:mp, i-1, 3, k)-cc(:mp, ic-1, 2, k))-TI11 &
                    *(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k)))) &
                    +wa3(i-1) &
                    *((cc(:mp, i-1, 1, k)+TR12*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR11*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))+(TI12*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))-TI11*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k))))

                ch(:mp, i-1, k, 5) = &
                    wa4(i-2) &
                    *((cc(:mp, i-1, 1, k)+TR11*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR12*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))+(TI11*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))+TI12*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k)))) &
                    -wa4(i-1) &
                    *((cc(:mp, i, 1, k)+TR11*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)) &
                    +TR12*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k)))-(TI11*(cc(:mp, i-1, 3, k) &
                    -cc(:mp, ic-1, 2, k))+TI12*(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k))))

                ch(:mp, i, k, 5) = &
                    wa4(i-2) &
                    *((cc(:mp, i, 1, k)+TR11*(cc(:mp, i, 3, k)-cc(:mp, ic, 2, k)) &
                    +TR12*(cc(:mp, i, 5, k)-cc(:mp, ic, 4, k)))-(TI11*(cc(:mp, i-1, 3, k) &
                    -cc(:mp, ic-1, 2, k))+TI12*(cc(:mp, i-1, 5, k)-cc(:mp, ic-1, 4, k)))) &
                    +wa4(i-1) &
                    *((cc(:mp, i-1, 1, k)+TR11*(cc(:mp, i-1, 3, k)+cc(:mp, ic-1, 2, k)) &
                    +TR12*(cc(:mp, i-1, 5, k)+cc(:mp, ic-1, 4, k)))+(TI11*(cc(:mp, i, 3, k) &
                    +cc(:mp, ic, 2, k))+TI12*(cc(:mp, i, 5, k)+cc(:mp, ic, 4, k))))
            end do
        end do

    end subroutine backward_pass_5

    subroutine backward_pass_n(mp, ido, iip, l1, idl1, cc, c1, c2, mdimcc, &
        ch, ch2, mdimch, wa)

        ! Dummy arguments
        integer(ip), intent(in)     :: mp
        integer(ip), intent(in)     :: ido
        integer(ip), intent(in)     :: iip
        integer(ip), intent(in)     :: l1
        integer(ip), intent(in)     :: idl1
        real(wp),    intent(inout)  :: cc(mdimcc, ido, iip, l1)
        real(wp),    intent(inout)  :: c1(mdimcc, ido, l1, iip)
        real(wp),    intent(inout)  :: c2(mdimcc, idl1, iip)
        integer(ip), intent(in)     :: mdimcc
        real(wp),    intent(inout)  :: ch(mdimch, ido, l1, iip)
        real(wp),    intent(inout)  :: ch2(mdimch, idl1, iip)
        integer(ip), intent(in)     :: mdimch
        real(wp),    intent(in)     :: wa(:)

        ! Local variables
        integer(ip)  :: i, j, k, l, j2, ic, jc, lc, iis, nbd
        integer(ip)  :: idp2, ipp2, idij, ipph
        real(wp)     :: dc2, ai1, ai2, ar1, ar2, ds2
        real(wp)     :: dcp, arg, dsp, ar1h, ar2h

        arg = TWO_PI/iip
        dcp = cos(arg)
        dsp = sin(arg)
        idp2 = ido+2
        nbd = (ido-1)/2
        ipp2 = iip+2
        ipph = (iip+1)/2

        ch(:mp, :, :, 1) = cc(:mp, :, 1, :)

        do j=2, ipph
            jc = ipp2-j
            j2 = 2*j
            ch(:mp, 1, :, j) = cc(:mp, ido, j2-2, :)+cc(:mp, ido, j2-2, :)
            ch(:mp, 1, :, jc) = cc(:mp, 1, j2-1, :)+cc(:mp, 1, j2-1, :)
        end do

        if (ido /= 1) then
            if (l1 <= nbd) then
                do j=2, ipph
                    jc = ipp2-j
                    do k=1, l1
                        do i=3, ido, 2
                            ic = idp2-i
                            ch(:mp, i-1, k, j) = cc(:mp, i-1, 2*j-1, k)+cc(:mp, ic-1, 2*j-2, k)
                            ch(:mp, i-1, k, jc) = cc(:mp, i-1, 2*j-1, k)-cc(:mp, ic-1, 2*j-2, k)
                            ch(:mp, i, k, j) = cc(:mp, i, 2*j-1, k)-cc(:mp, ic, 2*j-2, k)
                            ch(:mp, i, k, jc) = cc(:mp, i, 2*j-1, k)+cc(:mp, ic, 2*j-2, k)
                        end do
                    end do
                end do
            else
                do j=2, ipph
                    jc = ipp2-j
                    do i=3, ido, 2
                        ic = idp2-i
                        ch(:mp, i-1, :, j) = cc(:mp, i-1, 2*j-1, :)+cc(:mp, ic-1, 2*j-2, :)
                        ch(:mp, i-1, :, jc) = cc(:mp, i-1, 2*j-1, :)-cc(:mp, ic-1, 2*j-2, :)
                        ch(:mp, i, :, j) = cc(:mp, i, 2*j-1, :)-cc(:mp, ic, 2*j-2, :)
                        ch(:mp, i, :, jc) = cc(:mp, i, 2*j-1, :)+cc(:mp, ic, 2*j-2, :)
                    end do
                end do
            end if
        end if

        ar1 = ONE
        ai1 = ZERO
        do l=2, ipph
            lc = ipp2-l
            ar1h = dcp*ar1-dsp*ai1
            ai1 = dcp*ai1+dsp*ar1
            ar1 = ar1h
            c2(:mp, :idl1, l) = ch2(:mp, :idl1, 1)+ar1*ch2(:mp, :idl1, 2)
            c2(:mp, :idl1, lc) = ai1*ch2(:mp, :idl1, iip)
            dc2 = ar1
            ds2 = ai1
            ar2 = ar1
            ai2 = ai1
            do j=3, ipph
                jc = ipp2-j
                ar2h = dc2*ar2-ds2*ai2
                ai2 = dc2*ai2+ds2*ar2
                ar2 = ar2h
                c2(:mp, :idl1, l) = c2(:mp, :idl1, l)+ar2*ch2(:mp, :idl1, j)
                c2(:mp, :idl1, lc) = c2(:mp, :idl1, lc)+ai2*ch2(:mp, :idl1, jc)
            end do
        end do

        do j=2, ipph
            ch2(:mp, :idl1, 1) = ch2(:mp, :idl1, 1)+ch2(:mp, :idl1, j)
        end do

        do j=2, ipph
            jc = ipp2-j
            ch(:mp, 1, :l1, j) = c1(:mp, 1, :l1, j)-c1(:mp, 1, :l1, jc)
            ch(:mp, 1, :l1, jc) = c1(:mp, 1, :l1, j)+c1(:mp, 1, :l1, jc)
        end do

        if (ido /= 1) then
            if (l1 <= nbd) then
                do j=2, ipph
                    jc = ipp2-j
                    do k=1, l1
                        do i=3, ido, 2
                            ch(:mp, i-1, k, j) = c1(:mp, i-1, k, j)-c1(:mp, i, k, jc)
                            ch(:mp, i-1, k, jc) = c1(:mp, i-1, k, j)+c1(:mp, i, k, jc)
                            ch(:mp, i, k, j) = c1(:mp, i, k, j)+c1(:mp, i-1, k, jc)
                            ch(:mp, i, k, jc) = c1(:mp, i, k, j)-c1(:mp, i-1, k, jc)
                        end do
                    end do
                end do
            else
                do j=2, ipph
                    jc = ipp2-j
                    do i=3, ido, 2
                        ch(:mp, i-1, :l1, j) = c1(:mp, i-1, :l1, j)-c1(:mp, i, :l1, jc)
                        ch(:mp, i-1, :l1, jc) = c1(:mp, i-1, :l1, j)+c1(:mp, i, :l1, jc)
                        ch(:mp, i, :l1, j) = c1(:mp, i, :l1, j)+c1(:mp, i-1, :l1, jc)
                        ch(:mp, i, :l1, jc) = c1(:mp, i, :l1, j)-c1(:mp, i-1, :l1, jc)
                    end do
                end do
            end if
        end if

        if (ido /= 1) then
            c2(:mp, :idl1, 1) = ch2(:mp, :idl1, 1)
            c1(:mp, 1, :l1, 2:iip) = ch(:mp, 1, :l1, 2:iip)
            if (nbd <= l1) then
                iis = -ido
                do j=2, iip
                    iis = iis+ido
                    idij = iis
                    do i=3, ido, 2
                        idij = idij+2
                        do k=1, l1
                            c1(:mp, i-1, k, j) = &
                                wa(idij-1) * ch(:mp, i-1, k, j) &
                                - wa(idij) * ch(:mp, i, k, j)
                            c1(:mp, i, k, j) = &
                                wa(idij-1) * ch(:mp, i, k, j) &
                                + wa(idij) * ch(:mp, i-1, k, j)
                        end do
                    end do
                end do
            else
                iis = -ido
                do j=2, iip
                    iis = iis+ido
                    do k=1, l1
                        idij = iis
                        do i=3, ido, 2
                            idij = idij+2
                            c1(:mp, i-1, k, j) = &
                                wa(idij-1) * ch(:mp, i-1, k, j) &
                                - wa(idij) * ch(:mp, i, k, j)
                            c1(:mp, i, k, j) = &
                                wa(idij-1) * ch(:mp, i, k, j) &
                                + wa(idij) * ch(:mp, i-1, k, j)
                        end do
                    end do
                end do
            end if
        end if

    end subroutine backward_pass_n

end module type_RealPeriodicFastFourierTransform


program uranium
! Calculates Thomas-Fermi nonrelativistic energies for Z=92 (U)
!
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 1e6_dp
integer, parameter :: NN = 3000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-6_dp
integer :: converged, n, l, i
real(dp) :: R(NN+1), V(size(r)), E, P(size(r)), Q(size(r)), Rp(NN+1)

integer, parameter :: relat = 0
integer :: n_orb
integer, dimension(:), pointer :: no, lo
real(dp), dimension(:), pointer :: fo
real(dp), dimension(:), allocatable :: E_initial

call get_atomic_states_nonrel(Z, no, lo, fo)
n_orb = size(no)
allocate(E_initial(n_orb))

E_initial = get_tf_energies(Z, no, fo)

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
V = thomas_fermi_potential(R, Z)

print *, "Thomas Fermi nonrelativistic energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_exact", "Error"
print *
do i = 1, n_orb
    n = no(i)
    l = lo(i)
    call solve_radial_eigenproblem(n, l, E_initial(i), eps, 100, &
        R, Rp, V, Z, c, relat, .true., -10000._dp, 0._dp, converged, E, P, Q)
    print "(I3, I3, F15.6, F15.6, ES10.2)", n, l, E, E_initial(i), 0.0_dp
end do
deallocate(no, lo, fo)
end program


subroutine ff_sphere(q,R,ff,M)
    !***************************************************************************
    !Subroutine to calculate the form factor of sphere
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Radius of sphere in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1)
    double precision :: R, fact

    do i = 0,M-1
        fact=(sin(q(i)*R)-q(i)*R*cos(q(i)*R))/q(i)**3
        ff(i)=fact*fact
    enddo

end subroutine ff_sphere

subroutine ff_sphere_ML(q,R,rho,ff,aff,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of sphere with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radius and shell thicknesses of sphere in Angstroms
    !rho = Array of electron densities  of core and the shells
    !Rdist = Probablity distribution of radii
    !Nlayers = Number of shells plus the core
    !aff = amplitude of form factor
    !ff = Form factor of sphere
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, Nlayers, i, j
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1),aff(0:M-1)
    double precision :: R(0:Nlayers-1), rho(0:Nlayers-1)
    double precision :: fact,rt

    do i = 0,M-1
        fact=0.0d0
        rt=0.0d0
        do j=1,Nlayers-1
            rt=rt+R(j-1)
            fact=fact+(rho(j-1)-rho(j))*(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/q(i)**3
        end do
        aff(i)=fact
        ff(i) = fact*fact
    enddo
end subroutine ff_sphere_ML


program integration_test
    use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
    use :: gauss_mod, only : gen_gauss_type
    implicit none
    type(gen_gauss_type) :: quad
    integer :: n
    real(kind=dp) :: a = -1.0_dp, b = 1.0_dp, eps = 1.0e-9_dp
    character(len=1024) :: buffer

    if (command_argument_count() >= 3) then
        call get_command_argument(1, buffer)
        read (buffer, fmt='(I10)') n
        call get_command_argument(2, buffer)
        read (buffer, fmt='(E25.15)') a
        call get_command_argument(3, buffer)
        read (buffer, fmt='(E25.15)') b
    else
        write (unit=error_unit, fmt='(A)') &
            '#error: two command line argument expected, n, a, and b'
    end if
    call quad%init_gen_gauss(n, eps)
    print '(F25.15)', quad%integrate(f, a, b)

contains

    function f(x) result(r)
        implicit none
        real(kind=dp), intent(in) :: x
        real(kind=dp) :: r
        r = cos(x**2)*exp(0.37_dp*x)/(x**2 + 17.0_dp)
    end function f

end program integration_test


! !ROUTINE: Interpolate from time-series observation to model time
subroutine time_interp(time, N, nrow, obs_time, obs_data, mod_data)
! time: model time (in seconds)
!    N: number of time-series observations in observational data
! nrow: number of vertical points in observation data
! obs_time: time of observational data (in seconds), should be a vector of length N
! obs_data: observational data, should be a vector of length N
! mod_data: model data as output
implicit none
integer, intent(in)    :: N, time, nrow
real   , intent(in)    :: obs_time(N), obs_data(nrow,N)
real   , intent(out)   :: mod_data(nrow)

integer, parameter     :: y_per_s = 31104000
integer                :: i,j
real                   :: timeMOD, rat

! Get time of the year (mod):
   timeMOD = float(mod(time,y_per_s))

! Deal with the case between two years:
   IF ((timeMOD .lt. obs_time(1))) THEN

      rat = (timeMOD    -obs_time(N)+float(y_per_s))   &
          / (obs_time(1)-obs_time(N)+float(y_per_s))

      do i=1,nrow
         mod_data(i)=obs_data(i,N)*(1d0-rat)+obs_data(i,1)*rat
      enddo

   ELSEIF (timeMOD .ge. obs_time(N)) THEN

      rat = (timeMOD    -obs_time(N))   &
          / (obs_time(1)-obs_time(N)+float(y_per_s))

      do i=1,nrow
         mod_data(i)=obs_data(i,N)*(1d0-rat)+obs_data(i,1)*rat
      enddo

   ELSE

      do j = 1, N-1
         if ((timeMOD.lt.obs_time(j+1)) .and. (timeMOD.GE.obs_time(j))) then

            rat=(timeMOD-obs_time(j))/(obs_time(j+1)-obs_time(j))

            do i=1,nrow
               mod_data(i)=obs_data(i,j)*(1d0-rat)+obs_data(i,j+1)*rat
            enddo
            exit
         endif
      enddo

   ENDIF
   return
end subroutine time_interp


MODULE fourier
    USE kinds
    USE parameters
CONTAINS
    FUNCTION ft_at_omega(f,w,dt) RESULT(res)
        IMPLICIT NONE
        INTEGER :: itime
        REAL(dp), INTENT(in) :: f(:)
        REAL(dp), INTENT(in) :: w, dt
        REAL(dp) :: res
        res = 0.0_dp

        DO itime = 1, SIZE(f)
            res = res + dt * f(itime) * exp(- eye * w * (itime-1) * dt)
        END DO
    END FUNCTION ft_at_omega

END MODULE fourier


      SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC,
     $                   SCALE, SEPD, FERR, WR, WI, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the real discrete Lyapunov matrix equation
C
C            op(A)'*X*op(A) - X = scale*C
C
C     and/or estimate the quantity, called separation,
C
C         sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X)
C
C     where op(A) = A or A' (A**T) and C is symmetric (C = C').
C     (A' denotes the transpose of the matrix A.) A is N-by-N, the right
C     hand side C and the solution X are N-by-N, and scale is an output
C     scale factor, set less than or equal to 1 to avoid overflow in X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'X':  Compute the solution only;
C             = 'S':  Compute the separation only;
C             = 'B':  Compute both the solution and the separation.
C
C     FACT    CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix A is supplied on entry, as follows:
C             = 'F':  On entry, A and U contain the factors from the
C                     real Schur factorization of the matrix A;
C             = 'N':  The Schur factorization of A will be computed
C                     and the factors will be stored in A and U.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X, and C.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A. If FACT = 'F', then A contains
C             an upper quasi-triangular matrix in Schur canonical form.
C             On exit, if INFO = 0 or INFO = N+1, the leading N-by-N
C             part of this array contains the upper quasi-triangular
C             matrix in Schur canonical form from the Shur factorization
C             of A. The contents of array A is not modified if
C             FACT = 'F'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,N)
C             If FACT = 'F', then U is an input argument and on entry
C             it must contain the orthogonal matrix U from the real
C             Schur factorization of A.
C             If FACT = 'N', then U is an output argument and on exit,
C             if INFO = 0 or INFO = N+1, it contains the orthogonal
C             N-by-N matrix from the real Schur factorization of A.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry with JOB = 'X' or 'B', the leading N-by-N part of
C             this array must contain the symmetric matrix C.
C             On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1,
C             the leading N-by-N part of C has been overwritten by the
C             symmetric solution matrix X.
C             If JOB = 'S', C is not referenced.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= 1,        if JOB = 'S';
C             LDC >= MAX(1,N), otherwise.
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     SEPD    (output) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1,
C             SEPD contains the estimate in the 1-norm of
C             sepd(op(A),op(A)').
C             If JOB = 'X' or N = 0, SEPD is not referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains
C             an estimated forward error bound for the solution X.
C             If XTRUE is the true solution, FERR bounds the relative
C             error in the computed solution, measured in the Frobenius
C             norm:  norm(X - XTRUE)/norm(XTRUE).
C             If JOB = 'X' or JOB = 'S', FERR is not referenced.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
C             contain the real and imaginary parts, respectively, of the
C             eigenvalues of A.
C             If FACT = 'F', WR and WI are not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C             This array is not referenced if JOB = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
C             optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 1 and
C             If JOB = 'X' then
C                If FACT = 'F', LDWORK >= MAX(N*N,2*N);
C                If FACT = 'N', LDWORK >= MAX(N*N,3*N).
C             If JOB = 'S' or JOB = 'B' then
C                LDWORK >= 2*N*N + 2*N.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, the QR algorithm failed to compute all
C                   the eigenvalues (see LAPACK Library routine DGEES);
C                   elements i+1:n of WR and WI contain eigenvalues
C                   which have converged, and A contains the partially
C                   converged Schur form;
C             = N+1:  if matrix A has almost reciprocal eigenvalues;
C                   perturbed values were used to solve the equation
C                   (but the matrix A is unchanged).
C
C     METHOD
C
C     After reducing matrix A to real Schur canonical form (if needed),
C     a discrete-time version of the Bartels-Stewart algorithm is used.
C     A set of equivalent linear algebraic systems of equations of order
C     at most four are formed and solved using Gaussian elimination with
C     complete pivoting.
C
C     REFERENCES
C
C     [1] Barraud, A.Y.                   T
C         A numerical algorithm to solve A XA - X = Q.
C         IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.
C
C     [2] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     FURTHER COMMENTS
C
C     SEPD is defined as
C
C            sepd( op(A), op(A)' ) = sigma_min( T )
C
C     where sigma_min(T) is the smallest singular value of the
C     N*N-by-N*N matrix
C
C        T = kprod( op(A)', op(A)' ) - I(N**2).
C
C     I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the
C     Kronecker product. The program estimates sigma_min(T) by the
C     reciprocal of an estimate of the 1-norm of inverse(T). The true
C     reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by
C     more than a factor of N.
C
C     When SEPD is small, small changes in A, C can cause large changes
C     in the solution of the equation. An approximate bound on the
C     maximum relative error in the computed solution is
C
C                            EPS * norm(A)**2 / SEPD
C
C     where EPS is the machine precision.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Supersedes Release 2.0 routine MB03AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, October 1982.
C     Based on DGELPD by P. Petkov, Tech. University of Sofia, September
C     1993.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, May 2020.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, TRANA
      INTEGER            INFO, LDA, LDC, LDU, LDWORK, N
      DOUBLE PRECISION   FERR, SCALE, SEPD
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   U( LDU, * ), WI( * ), WR( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOFACT, NOTA, WANTBH, WANTSP, WANTX
      CHARACTER          NOTRA, UPLO
      INTEGER            I, IERR, KASE, LWA, MINWRK, SDIM
      DOUBLE PRECISION   EST, SCALEF
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
      INTEGER            ISAVE( 3 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      DOUBLE PRECISION   DLAMCH, DLANHS
      EXTERNAL           DLAMCH, DLANHS, LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEES, DLACN2, MB01RD, SB03MX, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      WANTX  = LSAME( JOB,   'X' )
      WANTSP = LSAME( JOB,   'S' )
      WANTBH = LSAME( JOB,   'B' )
      NOFACT = LSAME( FACT,  'N' )
      NOTA   = LSAME( TRANA, 'N' )
C
      INFO = 0
      IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN
         INFO = -1
      ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND.
     $                         .NOT.LSAME( TRANA, 'C' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( WANTSP .AND. LDC.LT.1 .OR.
     $    .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
C
C     Compute workspace.
C
      IF( WANTX ) THEN
         IF( NOFACT ) THEN
            MINWRK = MAX( N*N, 3*N )
         ELSE
            MINWRK = MAX( N*N, 2*N )
         END IF
      ELSE
         MINWRK = 2*N*N + 2*N
      END IF
      IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN
         INFO = -18
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         SCALE = ONE
         IF( WANTBH )
     $      FERR  = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
      LWA = 0
C
      IF( NOFACT ) THEN
C
C        Compute the Schur factorization of A.
C        Workspace:  need   3*N;
C                    prefer larger.
C
         CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM,
     $               WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
         IF( INFO.GT.0 )
     $      RETURN
         LWA = INT( DWORK( 1 ) )
      END IF
C
      IF( .NOT.WANTSP ) THEN
C
C        Transform the right-hand side.
C        Workspace:  need   N*N.
C
         UPLO   = 'U'
         CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U,
     $                LDU, C, LDC, DWORK, LDWORK, INFO )
C
         DO 10 I = 2, N
            CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC )
   10    CONTINUE
C
C        Solve the transformed equation.
C        Workspace:  2*N.
C
         CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO )
         IF( INFO.GT.0 )
     $      INFO = N + 1
C
C        Transform back the solution.
C
         CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U,
     $                LDU, C, LDC, DWORK, LDWORK, INFO )
C
         DO 20 I = 2, N
            CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC )
   20    CONTINUE
C
      END IF
C
      IF( .NOT.WANTX ) THEN
C
C        Estimate sepd(op(A),op(A)').
C        Workspace:  2*N*N + 2*N.
C
         IF( NOTA ) THEN
            NOTRA = 'T'
         ELSE
            NOTRA = 'N'
         END IF
C
         EST = ZERO
         KASE = 0
C        REPEAT
   30    CONTINUE
         CALL DLACN2( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE,
     $                ISAVE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
               CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF,
     $                      DWORK( 2*N*N + 1 ), IERR )
            ELSE
               CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF,
     $                      DWORK( 2*N*N + 1 ), IERR )
            END IF
            GO TO 30
         END IF
C        UNTIL KASE = 0
C
         SEPD = SCALEF / EST
C
         IF( WANTBH ) THEN
C
C           Compute the estimate of the relative error.
C
            FERR = DLAMCH( 'Precision' )*
     $             DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD
         END IF
      END IF
C
      DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) )
C
      RETURN
C *** Last line of SB03PD ***
      END


      subroutine mboost(m,vec,beta,vin,vout)
c     boosts the m vectors vin(0:3,m) into the vectors vout(0:3,m) (that can
c     be the same) in the direction of vec(3) (|vec|=1) with velocity
c     beta.  Lorents convention: (t,x,y,z).
      implicit none
      integer m
      real * 8 vec(3),beta,vin(0:3,m),vout(0:3,m)
      real * 8 betav,gamma
      real * 8 vdotb
      integer ipart,idim
      gamma=1/sqrt(1-beta**2)
      do ipart=1,m
         vdotb=vin(1,ipart)*vec(1)
     #         +vin(2,ipart)*vec(2)+vin(3,ipart)*vec(3)
         do idim=1,3
            vout(idim,ipart)=vin(idim,ipart)
     #           +vec(idim)*((gamma-1)*vdotb
     #           +gamma*beta*vin(0,ipart))
         enddo
         vout(0,ipart)=gamma*(vin(0,ipart)+vdotb*beta)
      enddo
      end

      subroutine mrotate(dir,sinphi,cosphi,vec)
c Rotates vector vec counterclockwise around the direction
c dir (|dir|=1) with angle phi, given sin phi and cos phi.
      implicit none
      real * 8 sinphi,cosphi,dir(3),vec(3)
      real * 8 dircrossvec(3),dirdotvec
      integer i
      dircrossvec(1)=dir(2)*vec(3)-dir(3)*vec(2)
      dircrossvec(2)=dir(3)*vec(1)-dir(1)*vec(3)
      dircrossvec(3)=dir(1)*vec(2)-dir(2)*vec(1)
      dirdotvec=dir(1)*vec(1)+dir(2)*vec(2)+dir(3)*vec(3)
      do i=1,3
         vec(i)=vec(i)+sinphi*dircrossvec(i)
     #        -(1-cosphi)*(vec(i)-dir(i)*dirdotvec)
      enddo
      end


$ Declare
   SUBROUTINE CrackGrowthThreshold (DK0, a, f, A0, dKth)
!
! parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: DK0
   DOUBLE PRECISION, INTENT(IN)    :: a
   DOUBLE PRECISION, INTENT(IN)    :: f
   DOUBLE PRECISION, INTENT(IN)    :: A0
   DOUBLE PRECISION, INTENT(OUT)   :: dKth
!
! declarations
   DOUBLE PRECISION  :: Cth, Cthm, Cthp, Rcl, asc0
   DOUBLE PRECISION  :: sc, Rth
!
! material: steel in air (NasGro equations, parameters
! acc. to Fitnet and German dissertation)
!
! Constants and parameters
   Cthm  = 0.2D0
   Cthp  = 2.D0
   Rcl   = 0.75D0
   asc0  = 0.0381D0           ! Correction factor for short cracks
   sc = DSQRT(a/(a+asc0))     ! cracks
!
! Constant value for dKth in case of large R-values
   IF (R.GE.Rcl) THEN
	  Rth = Rcl
	  Cth = Cthp
   ELSE IF (R.LT.0.D0) THEN
      Rth = R
	  Cth = Cthm
   ELSE
      Rth = R
	  Cth = Cthp
   END IF
!
! Determine dKth
   dKth = DK0*sc*(((1-A0)*(1-Rth)/(1-f))**(1+Cth*Rth))
!
! End subroutine
   RETURN
   END


module random_module
contains
   function random_integers(n) result(z)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      ! function return location
      integer, dimension(n) :: z
      ! local data
      integer :: i
      real :: r
      ! processing
      do i=1,n
         call random_number(r)
         z(i) = int(2147483448.*r)
      end do
   end function random_integers

   function random_reals(n) result(r)
      implicit none
      ! dummy argumentss
      integer, intent(in) :: n
      ! function return location
      double precision, dimension(n) :: r
      ! local data
      integer :: i
      integer, allocatable :: seed(:)
      ! processing
      call random_number(r)
   end function random_reals

   function random_strings(n, RECSIZ, NORECS) result(records)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n, RECSIZ, NORECS
      ! function return location
      character (len = RECSIZ), dimension(n) :: records
      ! local data
      integer :: i, recno
      real :: rnd
      character (len = 50), parameter :: INFILE = '/home/slacker/dat/data.dat'
      ! processing
      open (8,file=INFILE,access='direct',form='formatted',recl=RECSIZ)
      do i = 1, n
         call random_number(rnd)
         recno = int(NORECS * rnd)+1
         read (8,1000,rec=recno) records(i)
      end do
      close (8)
      1000 format (a)
   end function random_strings

   subroutine init_random_seed()
      implicit none
      ! local data
      integer :: i, n, clock
      integer, dimension(:), allocatable :: seed
      ! processing
      call random_seed(size = n)
      allocate(seed(n))
      call system_clock(count = clock)
      seed = clock+37*(/(i-1,i=1,n)/)
      call random_seed(put = seed)
      deallocate(seed)
   end subroutine init_random_seed
end module random_module


program cylinder
    implicit none

    real :: pi
    real :: radius
    real :: height
    real :: area
    real :: lateral_surface
    real :: volume

    pi = 3.141592

    print *, 'Enter cylinder base radius:'
    read(*,*) radius

    print *, 'Enter cylinder height:'
    read(*,*) height

    area = pi*radius**2.0
    volume = area*height
    lateral_surface = 2.0*pi*radius*height

    print *, 'The cylinder radius is:',radius
    print *, 'The cylinder height is:',height
    print *, 'The cylinder base area is:',area
    print *, 'The cylinder volume is:',volume
    print *, "The cylinder's lateral surface is:",lateral_surface
end program cylinder