module stafft
    use constants, only : pi, twopi, zero, one, two, f12, f14
    implicit none

    ! Fourier transform module.
    ! This is not a general purpose transform package but is designed to be
    ! quick for arrays of length 2^n. It will work if the array length is of
    ! the form 2^i * 3^j * 4^k * 5^l * 6^m (integer powers obviously).
    !
    ! Minimal error-checking is performed by the code below. The only check is that
    ! the initial factorisation can be performed.
    ! Therefore if the transforms are called with an array of length <2, or a trig array
    ! not matching the length of the array to be transformed the code will fail in a
    ! spectacular way (eg. Seg. fault or nonsense returned).
    ! It is up to the calling code to ensure everything is called sensibly.
    ! The reason for stripping error checking is to speed up the backend by performing
    ! less if() evaluations - as errors in practice seem to occur very rarely.
    ! So the good news is this should be a fast library - the bad is that you may have to pick
    ! around in it if there are failures.
    !
    ! To initialise the routines call init(n,factors,trig,ierr).
    ! This fills a factorisation array (factors), and a sin/cos array (trig).
    ! These must be kept in memory by the calling program.
    ! The init routine can be called multiple times with different arrays if more than
    ! one length of array is to be transformed.
    ! If a factorisation of the array length n cannot be found (as specified above)
    ! then the init routine will exit immediately and the integer ierr will be set to 1.
    ! If the init returns with ierr=0 then the call was successful.
    !
    ! Top-level subroutines contained in this module are:
    ! 1) initfft(n,factors,trig)        :
    !      Performs intialisation of the module, by working out the factors of n (the FFT length).
    !      This will fail if n is not factorised completely by 2,3,4,5,6.
    !      The trig array contains the necessary cosine and sine values.
    !      Both arrays passed to init **must** be kept between calls to routines in this module.
    ! 2) forfft(m,n,x,trig,factors)  :
    !      This performs a FFT of an array x containing m vectors of length n.
    !      The transform length is n.
    !      This inverse of this transform is obtained by revfft.
    ! 3) revfft(m,n,x,trig,factors)  :
    !      This performs an inverse FFT of an array x containing m vectors of length n.
    !      The transform length is n.
    !      This inverse of this transform is forfft.
    ! 4) dct(m,n,x,trig,factors)     :
    !      This performs a discrete cosine transform of an array x containing m vectors of length n.
    !      The transform length is n.
    !      This routine calls forfft and performs pre- and post- processing to obtain the transform.
    !      This transform is it's own inverse.
    ! 5) dst(m,n,x,trig,factors)     :
    !      This performs a discrete sine transform of an array x containing m vectors of length n.
    !      The transform length is n.
    !      This routine calls forfft and performs pre- and post- processing to obtain the transform.
    !      This transform is it's own inverse.
    !
    ! The storage of the transformed array is in 'Hermitian form'. This means that, for the jth vector
    ! the values x(j,1:nw) contain the cosine modes of the transform, while the values x(j,nw+1:n) contain
    ! the sine modes (in reverse order ie. wave number increasing from n back to nw+1).
    ! [Here, for even n, nw=n/2, and for odd n, nw=(n-1)/2].

    double precision , parameter :: &
        rt2      = 1.414213562373095048801688724209698078569671875376948073176679737990732d0   &
      , rtf12    = 0.7071067811865475244008443621048490392848359376884740365883398689953662d0  &
      , rtf516   = 0.5590169943749474241022934171828190588601545899028814310677243113526302d0  &
      , sinf2pi5 = 0.9510565162951535721164393333793821434056986341257502224473056444301532d0  &
      , sinfpi3  = 0.8660254037844386467637231707529361834714026269051903140279034897259665d0  &
      , sinfpi5  = 0.5877852522924731291687059546390727685976524376431459910722724807572785d0  &
      , sinrat   = 0.6180339887498948482045868343656381177203091798057628621354486227052605d0

    private :: rt2, rtf12, rtf516, sinf2pi5, sinfpi3, sinfpi5, sinrat

    contains

        ! Subroutine performs initialisation work for all the transforms.
        ! It calls routines to factorise the array length n and then sets up
        ! a trig array full of sin/cos values used in the transform backend.
        subroutine initfft(n, factors, trig)
            integer,          intent(in)    :: n
            integer,          intent(inout) :: factors(5)
            double precision, intent(out)   :: trig(2*n)
            double precision                :: ftwopin
            integer                         :: i, j, k, l, m, fac(5), rem, ierr

            ! First factorise n:
            call factorisen(n, factors, ierr)

            ! Return if factorisation unsuccessful:
            if (ierr == 1) then
                ! Catastrophic end to run if factorisation fails:
                write(*,*) '****************************'
                write(*,*) ' Factorisation not possible.'
                write(*,*) ' Only factors from 2-6 allowed.'
                write(*,*) ' STOPPING...'
                write(*,*) '****************************'
                stop
            endif

            ! Define list of factors array:
            fac(1) = 6
            fac(2) = 4
            fac(3) = 2
            fac(4) = 3
            fac(5) = 5

            ! Define constants needed in trig array definition:
            ftwopin = twopi / dble(n)
            rem = n
            m = 1
            do i = 1, 5
                do j = 1, factors(i)
                    rem = rem / fac(i)
                    do k = 1, fac(i)-1
                        do l = 0, rem-1
                            trig(m) = ftwopin * dble(k * l)
                            m = m + 1
                        enddo
                    enddo
                    ftwopin = ftwopin * fac(i)
                enddo
            enddo

            do i = 1, n-1
                trig(n+i) = -dsin(trig(i))
                trig(i)   =  dcos(trig(i))
            enddo
        end subroutine

        subroutine factorisen(n, factors, ierr)
            integer, intent(in)    :: n
            integer, intent(inout) :: factors(5), ierr
            integer             :: i, rem

            ierr = 0
            ! Initialiase factors array:
            do i=1, 5
                factors(i)=0
            enddo

            rem=n
            ! Find factors of 6:
            do while (mod(rem, 6) == 0)
                factors(1) = factors(1) + 1
                rem = rem / 6
                if (rem == 1) then
                    return
                endif
            enddo

            ! Find factors of 4:
            do while (mod(rem, 4) == 0)
                factors(2) = factors(2) + 1
                rem = rem / 4
                if (rem == 1) then
                    return
                endif
            enddo

            ! Find factors of 2:
            do while (mod(rem,2) == 0)
                factors(3) = factors(3) + 1
                rem = rem / 2
                if (rem == 1) then
                    return
                endif
            enddo

            ! Find factors of 3:
            do while (mod(rem,3) == 0)
                factors(4) = factors(4) + 1
                rem = rem / 3
                if (rem == 1) then
                    return
                endif
            enddo

            ! Find factors of 5:
            do while (mod(rem,5) == 0)
                factors(5) = factors(5) + 1
                rem = rem / 5
                if (rem == 1) then
                    return
                endif
            enddo
            ! If code reaches this point factorisation has
            ! failed - return error code in ierr:
            ierr = 1
        end subroutine

        ! Main physical to spectral (forward) FFT routine.
        ! Performs m transforms of length n in the array x which is dimensioned x(m, n).
        ! The arrays trig and factors are filled by the init routine and
        ! should be kept from call to call.
        ! Backend consists of mixed-radix routines, with 'decimation in time'.
        ! Transform is stored in Hermitian form.
        subroutine forfft(m, n, x, trig, factors)
            integer,          intent(in)    :: m, n
            double precision, intent(inout) :: x(0:m*n-1), trig(0:2*n-1)
            integer,          intent(in)    :: factors(5)
            double precision                :: wk(0:m*n-1), normfac
            integer                         :: i, rem, cum, iloc
            logical                         :: orig

            ! Initialise flip/flop logical and counters
            orig = .true.
            rem = n
            cum = 1

            ! Use factors of 5:
            do i = 1, factors(5)
                rem = rem / 5
                iloc = (rem - 1) * 5 * cum
                if (orig) then
                    call forrdx5(x, wk, m*rem, cum, trig(iloc), trig(n+iloc))
                else
                    call forrdx5(wk, x, m*rem, cum, trig(iloc), trig(n+iloc))
                endif
                orig = .not. orig
                cum = cum * 5
            enddo

            ! Use factors of 3:
            do i = 1, factors(4)
                rem = rem / 3
                iloc = (rem - 1) * 3 * cum
                if (orig) then
                    call forrdx3(x, wk, m*rem, cum, trig(iloc), trig(n+iloc))
                else
                    call forrdx3(wk, x, m*rem, cum, trig(iloc), trig(n+iloc))
                endif
                orig = .not. orig
                cum = cum * 3
            enddo

            ! Use factors of 2:
            do i = 1, factors(3)
                rem = rem / 2
                iloc = (rem - 1) * 2 * cum
                if (orig) then
                    call forrdx2(x, wk, m*rem, cum, trig(iloc), trig(n+iloc))
                else
                    call forrdx2(wk, x, m*rem, cum, trig(iloc), trig(n+iloc))
                endif
                orig = .not. orig
                cum = cum * 2
            enddo

            ! Use factors of 4:
            do i = 1, factors(2)
                rem = rem / 4
                iloc = (rem - 1) * 4 * cum
                if (orig) then
                    call forrdx4(x, wk, m*rem, cum, trig(iloc), trig(n+iloc))
                else
                    call forrdx4(wk, x, m*rem, cum, trig(iloc), trig(n+iloc))
                endif
                orig = .not. orig
                cum = cum * 4
            enddo

            ! Use factors of 6:
            do i= 1, factors(1)
                rem = rem / 6
                iloc =(rem - 1) * 6 * cum
                if (orig) then
                    call forrdx6(x, wk, m*rem, cum, trig(iloc), trig(n+iloc))
                else
                    call forrdx6(wk, x, m*rem, cum, trig(iloc), trig(n+iloc))
                endif
                orig = .not. orig
                cum = cum * 6
            enddo

            ! Multiply by the normalisation constant and put
            ! transformed array in the right location:
            normfac = one / dsqrt(dble(n))
            if (orig) then
                do i= 0, m * n - 1
                    x(i) = x(i) * normfac
                enddo
            else
                do i = 0, m * n - 1
                    x(i) = wk(i) * normfac
                enddo
            endif
    end subroutine

    ! Main spectral to physical (reverse) FFT routine.
    ! Performs m reverse transforms of length n in the array x which is dimensioned x(m, n).
    ! The arrays trig and factors are filled by the init routine and
    ! should be kept from call to call.
    ! Backend consists of mixed-radix routines, with 'decimation in frequency'.
    ! Reverse transform starts in Hermitian form.
    subroutine revfft(m, n, x, trig, factors)
        integer,          intent(in)    :: m, n
        double precision, intent(inout) :: x(0:m*n-1), trig(0:2*n-1)
        integer,          intent(in)    :: factors(5)
        double precision                :: wk(0:m*n-1), normfac
        integer                         :: i, k, cum, rem, iloc
        logical                         :: orig

        ! Flip the sign of the sine coefficients:
        do i = (n / 2 + 1) * m, n * m - 1
            x(i) = -x(i)
        enddo

        !Scale 0 and Nyquist frequencies:
        do i= 0, m-1
            x(i) = f12 * x(i)
        enddo
        if (mod(n, 2) == 0) then
            k = m * n / 2
            do i = 0, m-1
                x(k+i) = f12 * x(k+i)
            enddo
        endif

        ! Initialise flip/flop logical and counters
        orig=.true.
        cum = 1
        rem = n

        ! Use factors of 6:
        do i = 1, factors(1)
            rem = rem / 6
            iloc = (cum - 1) * 6 * rem
            if (orig) then
                call revrdx6(x, wk, m*cum, rem, trig(iloc), trig(n+iloc))
            else
                call revrdx6(wk, x, m*cum, rem, trig(iloc), trig(n+iloc))
            endif
            orig = .not. orig
            cum = cum * 6
        enddo

        ! Use factors of 4:
        do i = 1, factors(2)
            rem = rem / 4
            iloc = (cum - 1) * 4 * rem
            if (orig) then
                call revrdx4(x, wk, m*cum, rem, trig(iloc), trig(n+iloc))
            else
                call revrdx4(wk, x, m*cum, rem, trig(iloc), trig(n+iloc))
            endif
            orig = .not. orig
            cum = cum * 4
        enddo

        ! Use factors of 2:
        do i = 1, factors(3)
            rem = rem / 2
            iloc = (cum - 1) * 2 * rem
            if (orig) then
                call revrdx2(x, wk, m*cum, rem, trig(iloc), trig(n+iloc))
            else
                call revrdx2(wk, x, m*cum, rem, trig(iloc), trig(n+iloc))
            endif
            orig = .not. orig
            cum = cum * 2
        enddo

        ! Use factors of 3:
        do i = 1, factors(4)
            rem = rem / 3
            iloc = (cum - 1) * 3 * rem
            if (orig) then
                call revrdx3(x, wk, m*cum, rem, trig(iloc), trig(n+iloc))
            else
                call revrdx3(wk, x, m*cum, rem, trig(iloc), trig(n+iloc))
            endif
            orig = .not. orig
            cum = cum * 3
        enddo

        ! Use factors of 5:
        do i = 1, factors(5)
            rem = rem / 5
            iloc = (cum - 1) * 5 * rem
            if (orig) then
                call revrdx5(x, wk, m*cum, rem, trig(iloc), trig(n+iloc))
            else
                call revrdx5(wk, x, m*cum, rem, trig(iloc), trig(n+iloc))
            endif
            orig = .not. orig
            cum = cum * 5
        enddo

        ! Multiply by the normalisation constant and put
        ! transformed array in the right location:
        normfac = two / dsqrt(dble(n))
        if (orig) then
            do i = 0, m * n - 1
                x(i) = x(i) * normfac
            enddo
            else
            do i = 0, m * n - 1
                x(i) = wk(i) * normfac
            enddo
        endif
    end subroutine

    ! This routine computes multiple fourier cosine transforms of sequences
    ! of doubles using the forfft routine to compute the FFT,
    ! along with pre- and post-processing steps to extract the dst.
    subroutine dct(m, n, x, trig, factors)
        integer,          intent(in)    :: m, n, factors(5)
        double precision, intent(inout) :: x(m, 0:n), trig(2 * n)
        double precision                :: wk(1:m, 0:n - 1), fpin, rtn, rowsum
        integer                         :: i, j, nd2

        fpin = pi / dble(n)
        rtn = dsqrt(dble(n))

        !Pre-process the array and store it in wk:
        do i = 1, m
            wk(i, 0) = f12 * (x(i, 0) + x(i, n))
        enddo

        do j = 1, n - 1
            do i = 1, m
                wk(i, j) = f12 * (x(i, j) + x(i, n - j)) - dsin(dble(j) * fpin) * (x(i, j) - x(i, n - j))
            enddo
        enddo

        !Get the first element of the transform x(i, 1) and store
        !in x(i, n), as this is not overwritten when x is used
        !as a work array in the forfft routine called next:
        do i = 1, m
            rowsum = zero
            rowsum = rowsum + f12 * x(i, 0)
            do j = 1, n - 1
                rowsum = rowsum + x(i, j) * dcos(dble(j) * fpin)
            enddo
            rowsum = rowsum - f12 * x(i, n)
            x(i, n) = rt2 * rowsum / rtn
        enddo

        !Transform the wk array by use of the general FFT routine:
        call forfft(m, n, wk, trig, factors)

        !Post-process the result of the FFT to get the dst of x and
        !put the result back into the x array:
        do i = 1, m
            x(i, 0) = rt2 * wk(i, 0)
        enddo
        do i = 1, m
            x(i, 1) = x(i, n)
        enddo

        if (mod(n, 2) == 0) then
            nd2 = n / 2
            do j = 1, nd2 - 1
                do i = 1, m
                    x(i, 2 * j) = rt2 * wk(i, j)
                    x(i, 2 * j + 1) = x(i, 2 * j - 1) - rt2 * wk(i, n - j)
                enddo
            enddo
            do i = 1, m
                x(i, n) = rt2 * wk(i, nd2)
            enddo
        else if (mod(n, 2) == 1) then
            do j = 1, (n - 1) / 2
                do i = 1, m
                    x(i, 2 * j) = rt2 * wk(i, j)
                    x(i, 2 * j + 1) = x(i, 2 * j - 1) - rt2 * wk(i, n - j)
                enddo
            enddo
        endif
    end subroutine

    ! This routine computes multiple fourier sine transforms of sequences
    ! of doubles using the forfft routine to compute the FFT,
    ! along with pre- and post-processing steps to extract the dst.
    subroutine dst(m, n, x, trig, factors)
        integer, intent(in)             :: m, n, factors(5)
        double precision, intent(inout) :: x(m, n), trig(2 * n)
        double precision                :: wk(1:m, 0:n - 1), fpin
        integer                         :: i, j

        fpin = pi / dble(n)

        !Pre-process the array and store it in wk:
        !First set 0 frequency element to zero:
        do i = 1, m
            wk(i, 0) = zero
        enddo

        !Next set up the rest of the array:
        do j = 1, n - 1
            do i = 1, m
                wk(i, j) = f12 * (x(i, j) - x(i, n - j)) + dsin(dble(j) * fpin) * (x(i, j) + x(i, n - j))
            enddo
        enddo

        !Transform the wk array by use of the general FFT routine:
        call forfft(m, n, wk, trig, factors)

        !Post-process the result of the FFT to get the dst of x and
        !put the result back into the x array:
        do i = 1, m
            x(i, 1) = wk(i, 0) / rt2
        enddo
        if (mod(n, 2) == 0) then
            do j = 1, n / 2 - 1
                do i = 1, m
                    x(i, 2 * j) = - rt2 * wk(i, n - j)
                enddo
                do i = 1, m
                    x(i, 2 * j + 1) = rt2 * wk(i, j) + x(i, 2 * j - 1)
                enddo
            enddo
        else if (mod(n, 2) == 1) then
            do j = 1, (n - 1) / 2 - 1
                do i = 1, m
                    x(i, 2 * j) = - rt2 * wk(i, n - j)
                    x(i, 2 * j + 1) = rt2 * wk(i, j) + x(i, 2 * j - 1)
                enddo
            enddo
            do i = 1, m
                x(i, n - 1) = - rt2 * wk(i, (n + 1) / 2)
            enddo
        endif

        !  Set the Nyquist frequency element to zero:
        do i = 1, m
            x(i, n) = zero
        enddo
    end subroutine

    !====================================================
    !  Internal radix routines only beyond this point...
    !  Abandon hope all ye who enter in!
    !====================================================
    ! Physical to spectral (forward) routines:
    !====================================================

    ! Radix six physical to Hermitian FFT with 'decimation in time'.
    subroutine forrdx6(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:5, 0:lv - 1)  &
                                         , b(0:nv - 1, 0:lv - 1, 0:5)  &
                                         , cosine(0:lv - 1, 5)         &
                                         , sine(0:lv - 1, 5)
        double precision                :: x1p, x2p, x3p, x4p, x5p
        double precision                :: y1p, y2p, y3p, y4p, y5p
        double precision                :: s1k, s2k, s3k, s4k, s5k
        double precision                :: c1k, c2k, c3k, c4k, c5k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r
        double precision                :: u0i, u0r, u1i, u1r, u2i, u2r
        double precision                :: v0i, v0r, v1i, v1r, v2i, v2r
        double precision                :: q1, q2, q3, q4, q5, q6
        integer                         :: i, k, kc, lvd2

        !Do k = 0 first:
        do i = 0, nv - 1
            t1r = a(i, 2, 0) + a(i, 4, 0)
            t2r = a(i, 0, 0) - f12 * t1r
            t3r = sinfpi3 * (a(i, 4, 0) - a(i, 2, 0))
            u0r = a(i, 0, 0) + t1r
            t1i = a(i, 5, 0) + a(i, 1, 0)
            t2i = a(i, 3, 0) - f12 * t1i
            t3i = sinfpi3 * (a(i, 5, 0) - a(i, 1, 0))
            v0r = a(i, 3, 0) + t1i
            b(i, 0, 0) = u0r + v0r
            b(i, 0, 1) = t2r - t2i
            b(i, 0, 2) = t2r + t2i
            b(i, 0, 3) = u0r - v0r
            b(i, 0, 4) = t3i - t3r
            b(i, 0, 5) = t3r + t3i
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1p = cosine(k, 1) * a(i, 1,  k) - sine(k, 1) * a(i, 1, kc)
                    y1p = cosine(k, 1) * a(i, 1, kc) + sine(k, 1) * a(i, 1,  k)
                    x2p = cosine(k, 2) * a(i, 2,  k) - sine(k, 2) * a(i, 2, kc)
                    y2p = cosine(k, 2) * a(i, 2, kc) + sine(k, 2) * a(i, 2,  k)
                    x3p = cosine(k, 3) * a(i, 3,  k) - sine(k, 3) * a(i, 3, kc)
                    y3p = cosine(k, 3) * a(i, 3, kc) + sine(k, 3) * a(i, 3,  k)
                    x4p = cosine(k, 4) * a(i, 4,  k) - sine(k, 4) * a(i, 4, kc)
                    y4p = cosine(k, 4) * a(i, 4, kc) + sine(k, 4) * a(i, 4,  k)
                    x5p = cosine(k, 5) * a(i, 5,  k) - sine(k, 5) * a(i, 5, kc)
                    y5p = cosine(k, 5) * a(i, 5, kc) + sine(k, 5) * a(i, 5,  k)
                    t1r = x2p + x4p
                    t1i = y2p + y4p
                    t2r = a(i, 0, k) - f12 * t1r
                    t2i = a(i, 0, kc) - f12 * t1i
                    t3r = sinfpi3 * (x2p - x4p)
                    t3i = sinfpi3 * (y2p - y4p)
                    u0r = a(i, 0, k) + t1r
                    u0i = a(i, 0, kc) + t1i
                    u1r = t2r + t3i
                    u1i = t2i - t3r
                    u2r = t2r - t3i
                    u2i = t2i + t3r
                    t1r = x5p + x1p
                    t1i = y5p + y1p
                    t2r = x3p - f12 * t1r
                    t2i = y3p - f12 * t1i
                    t3r = sinfpi3 * (x5p - x1p)
                    t3i = sinfpi3 * (y5p - y1p)
                    v0r = x3p + t1r
                    v0i = y3p + t1i
                    v1r = t2r + t3i
                    v1i = t3r - t2i
                    v2r = t2r - t3i
                    v2i = t2i + t3r
                    b(i,  k, 0) = u0r + v0r
                    b(i, kc, 0) = u2r - v2r
                    b(i,  k, 1) = u1r - v1r
                    b(i, kc, 1) = u1r + v1r
                    b(i,  k, 2) = u2r + v2r
                    b(i, kc, 2) = u0r - v0r
                    b(i,  k, 3) = v0i - u0i
                    b(i, kc, 3) = u2i + v2i
                    b(i,  k, 4) = v1i - u1i
                    b(i, kc, 4) = u1i + v1i
                    b(i,  k, 5) = v2i - u2i
                    b(i, kc, 5) = u0i + v0i
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                c4k = cosine(k, 4)
                s4k = sine(k, 4)
                c5k = cosine(k, 5)
                s5k = sine(k, 5)
                do i = 0, nv - 1
                    x1p = c1k * a(i, 1,  k) - s1k * a(i, 1, kc)
                    y1p = c1k * a(i, 1, kc) + s1k * a(i, 1,  k)
                    x2p = c2k * a(i, 2,  k) - s2k * a(i, 2, kc)
                    y2p = c2k * a(i, 2, kc) + s2k * a(i, 2,  k)
                    x3p = c3k * a(i, 3,  k) - s3k * a(i, 3, kc)
                    y3p = c3k * a(i, 3, kc) + s3k * a(i, 3,  k)
                    x4p = c4k * a(i, 4,  k) - s4k * a(i, 4, kc)
                    y4p = c4k * a(i, 4, kc) + s4k * a(i, 4,  k)
                    x5p = c5k * a(i, 5,  k) - s5k * a(i, 5, kc)
                    y5p = c5k * a(i, 5, kc) + s5k * a(i, 5,  k)
                    t1r = x2p + x4p
                    t1i = y2p + y4p
                    t2r = a(i, 0, k) - f12 * t1r
                    t2i = a(i, 0, kc) - f12 * t1i
                    t3r = sinfpi3 * (x2p - x4p)
                    t3i = sinfpi3 * (y2p - y4p)
                    u0r = a(i, 0, k) + t1r
                    u0i = a(i, 0, kc) + t1i
                    u1r = t2r + t3i
                    u1i = t2i - t3r
                    u2r = t2r - t3i
                    u2i = t2i + t3r
                    t1r = x5p + x1p
                    t1i = y5p + y1p
                    t2r = x3p - f12 * t1r
                    t2i = y3p - f12 * t1i
                    t3r = sinfpi3 * (x5p - x1p)
                    t3i = sinfpi3 * (y5p - y1p)
                    v0r = x3p + t1r
                    v0i = y3p + t1i
                    v1r = t2r + t3i
                    v1i = t3r - t2i
                    v2r = t2r - t3i
                    v2i = t2i + t3r
                    b(i,  k, 0) = u0r + v0r
                    b(i, kc, 0) = u2r - v2r
                    b(i,  k, 1) = u1r - v1r
                    b(i, kc, 1) = u1r + v1r
                    b(i,  k, 2) = u2r + v2r
                    b(i, kc, 2) = u0r - v0r
                    b(i,  k, 3) = v0i - u0i
                    b(i, kc, 3) = u2i + v2i
                    b(i,  k, 4) = v1i - u1i
                    b(i, kc, 4) = u1i + v1i
                    b(i,  k, 5) = v2i - u2i
                    b(i, kc, 5) = u0i + v0i
                enddo
            enddo
        endif

        !Catch the case k = lv / 2 when lv even:
        if (mod(lv, 2) == 0) then
            lvd2 = lv / 2
            do i = 0, nv - 1
                q1 = a(i, 2, lvd2) - a(i, 4, lvd2)
                q2 = a(i, 0, lvd2) + f12 * q1
                q3 = sinfpi3 * (a(i, 2, lvd2) + a(i, 4, lvd2))
                q4 = a(i, 1, lvd2) + a(i, 5, lvd2)
                q5 = - a(i, 3, lvd2) - f12 * q4
                q6 = sinfpi3 * (a(i, 1, lvd2) - a(i, 5, lvd2))
                b(i, lvd2, 0) = q2 + q6
                b(i, lvd2, 1) = a(i, 0, lvd2) - q1
                b(i, lvd2, 2) = q2 - q6
                b(i, lvd2, 3) = q5 + q3
                b(i, lvd2, 4) = a(i, 3, lvd2) - q4
                b(i, lvd2, 5) = q5 - q3
            enddo
        endif
    end subroutine

    ! Radix five physical to Hermitian FFT with 'decimation in time'.
    subroutine forrdx5(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:4, 0:lv - 1)  &
                                         , b(0:nv - 1, 0:lv - 1, 0:4)  &
                                         , cosine(0:lv - 1, 1:4)       &
                                         , sine(0:lv - 1, 1:4)
        double precision                :: x1p, x2p, x3p, x4p, y1p, y2p, y3p, y4p
        double precision                :: s1k, s2k, s3k, s4k, c1k, c2k, c3k, c4k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r, t4i, t4r, t5i, t5r, t6i, t6r
        double precision                :: t7i, t7r, t8i, t8r, t9i, t9r, t10i, t10r, t11i, t11r
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            t1r = a(i, 1, 0) + a(i, 4, 0)
            t2r = a(i, 2, 0) + a(i, 3, 0)
            t3r = sinf2pi5 * (a(i, 4, 0) - a(i, 1, 0))
            t4r = sinf2pi5 * (a(i, 2, 0) - a(i, 3, 0))
            t5r = t1r + t2r
            t6r = rtf516 * (t1r - t2r)
            t7r = a(i, 0, 0) - f14 * t5r
            b(i, 0, 0) = a(i, 0, 0) + t5r
            b(i, 0, 1) = t7r + t6r
            b(i, 0, 2) = t7r - t6r
            b(i, 0, 3) = t4r + sinrat * t3r
            b(i, 0, 4) = t3r - sinrat * t4r
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1p = cosine(k, 1) * a(i, 1,  k) - sine(k, 1) * a(i, 1, kc)
                    y1p = cosine(k, 1) * a(i, 1, kc) + sine(k, 1) * a(i, 1,  k)
                    x2p = cosine(k, 2) * a(i, 2,  k) - sine(k, 2) * a(i, 2, kc)
                    y2p = cosine(k, 2) * a(i, 2, kc) + sine(k, 2) * a(i, 2,  k)
                    x3p = cosine(k, 3) * a(i, 3,  k) - sine(k, 3) * a(i, 3, kc)
                    y3p = cosine(k, 3) * a(i, 3, kc) + sine(k, 3) * a(i, 3,  k)
                    x4p = cosine(k, 4) * a(i, 4,  k) - sine(k, 4) * a(i, 4, kc)
                    y4p = cosine(k, 4) * a(i, 4, kc) + sine(k, 4) * a(i, 4,  k)
                    t1r = x1p + x4p
                    t1i = y1p + y4p
                    t2r = x2p + x3p
                    t2i = y2p + y3p
                    t3r = sinf2pi5 * (x1p - x4p)
                    t3i = sinf2pi5 * (y1p - y4p)
                    t4r = sinf2pi5 * (x2p - x3p)
                    t4i = sinf2pi5 * (y2p - y3p)
                    t5r = t1r + t2r
                    t5i = t1i + t2i
                    t6r = rtf516 * (t1r - t2r)
                    t6i = rtf516 * (t1i - t2i)
                    t7r = a(i, 0, k) - f14 * t5r
                    t7i = a(i, 0, kc) - f14 * t5i
                    t8r = t7r + t6r
                    t8i = t7i + t6i
                    t9r = t7r - t6r
                    t9i = t7i - t6i
                    t10r = t3r + sinrat * t4r
                    t10i = t3i + sinrat * t4i
                    t11r = t4r - sinrat * t3r
                    t11i = sinrat * t3i - t4i
                    b(i,  k, 0) = a(i, 0, k) + t5r
                    b(i, kc, 0) = t8r - t10i
                    b(i,  k, 1) = t8r + t10i
                    b(i, kc, 1) = t9r - t11i
                    b(i,  k, 2) = t9r + t11i
                    b(i, kc, 2) = t9i + t11r
                    b(i,  k, 3) = t11r - t9i
                    b(i, kc, 3) = t8i - t10r
                    b(i,  k, 4) = - t8i - t10r
                    b(i, kc, 4) = a(i, 0, kc) + t5i
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                c4k = cosine(k, 4)
                s4k = sine(k, 4)
                do i = 0, nv - 1
                    x1p = c1k * a(i, 1,  k) - s1k * a(i, 1, kc)
                    y1p = c1k * a(i, 1, kc) + s1k * a(i, 1,  k)
                    x2p = c2k * a(i, 2,  k) - s2k * a(i, 2, kc)
                    y2p = c2k * a(i, 2, kc) + s2k * a(i, 2,  k)
                    x3p = c3k * a(i, 3,  k) - s3k * a(i, 3, kc)
                    y3p = c3k * a(i, 3, kc) + s3k * a(i, 3,  k)
                    x4p = c4k * a(i, 4,  k) - s4k * a(i, 4, kc)
                    y4p = c4k * a(i, 4, kc) + s4k * a(i, 4,  k)
                    t1r = x1p + x4p
                    t1i = y1p + y4p
                    t2r = x2p + x3p
                    t2i = y2p + y3p
                    t3r = sinf2pi5 * (x1p - x4p)
                    t3i = sinf2pi5 * (y1p - y4p)
                    t4r = sinf2pi5 * (x2p - x3p)
                    t4i = sinf2pi5 * (y2p - y3p)
                    t5r = t1r + t2r
                    t5i = t1i + t2i
                    t6r = rtf516 * (t1r - t2r)
                    t6i = rtf516 * (t1i - t2i)
                    t7r = a(i, 0, k) - f14 * t5r
                    t7i = a(i, 0, kc) - f14 * t5i
                    t8r = t7r + t6r
                    t8i = t7i + t6i
                    t9r = t7r - t6r
                    t9i = t7i - t6i
                    t10r = t3r + sinrat * t4r
                    t10i = t3i + sinrat * t4i
                    t11r = t4r - sinrat * t3r
                    t11i = sinrat * t3i - t4i
                    b(i,  k, 0) = a(i, 0, k) + t5r
                    b(i, kc, 0) = t8r - t10i
                    b(i,  k, 1) = t8r + t10i
                    b(i, kc, 1) = t9r - t11i
                    b(i,  k, 2) = t9r + t11i
                    b(i, kc, 2) = t9i + t11r
                    b(i,  k, 3) = t11r - t9i
                    b(i, kc, 3) = t8i - t10r
                    b(i,  k, 4) = - t8i - t10r
                    b(i, kc, 4) = a(i, 0, kc) + t5i
                enddo
            enddo
        endif
    end subroutine

    ! Radix four physical to Hermitian FFT with 'decimation in time'.
    subroutine forrdx4(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:3, 0:lv - 1) &
                                         , b(0:nv - 1, 0:lv - 1, 0:3) &
                                         , cosine(0:lv - 1, 1:3)      &
                                         , sine(0:lv - 1, 1:3)
        double precision                :: x1p,x2p, x3p, y1p, y2p, y3p
        double precision                :: s1k, s2k, s3k, c1k,c2k,c3k
        double precision                :: t1i,t1r,t2i,t2r,t3i,t3r,t4i,t4r
        double precision                :: q1,q2
        integer                         :: i,k,kc,lvd2

        !Do k = 0 first:
        do i = 0,nv - 1
            t1r = a(i,0,0) + a(i,2,0)
            t2r = a(i, 1, 0) + a(i, 3, 0)
            b(i, 0, 0) = t1r + t2r
            b(i, 0, 1) = a(i,0, 0) - a(i, 2, 0)
            b(i, 0, 2) = t1r - t2r
            b(i, 0, 3) = a(i, 3, 0) - a(i, 1, 0)
        enddo
        !Next do remaining k:
        if (nv .lt. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1p = cosine(k, 1) * a(i, 1,  k) - sine(k, 1) * a(i, 1, kc)
                    y1p = cosine(k, 1) * a(i, 1, kc) + sine(k, 1) * a(i, 1,  k)
                    x2p = cosine(k, 2) * a(i, 2,  k) - sine(k, 2) * a(i, 2, kc)
                    y2p = cosine(k, 2) * a(i, 2, kc) + sine(k, 2) * a(i, 2,  k)
                    x3p = cosine(k, 3) * a(i, 3,  k) - sine(k, 3) * a(i, 3, kc)
                    y3p = cosine(k, 3) * a(i, 3, kc) + sine(k, 3) * a(i, 3,  k)
                    t1r = a(i, 0, k) + x2p
                    t1i = a(i, 0, kc) + y2p
                    t2r = x1p + x3p
                    t2i = y1p + y3p
                    t3r = a(i, 0, k) - x2p
                    t3i = a(i, 0, kc) - y2p
                    t4r = x3p - x1p
                    t4i = y1p - y3p
                    b(i,  k, 0) = t1r + t2r
                    b(i, kc, 0) = t3r - t4i
                    b(i,  k, 1) = t3r + t4i
                    b(i, kc, 1) = t1r - t2r
                    b(i,  k, 2) = t2i - t1i
                    b(i, kc, 2) = t3i + t4r
                    b(i,  k, 3) = t4r - t3i
                    b(i, kc, 3) = t1i + t2i
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                do i = 0, nv - 1
                    x1p = c1k * a(i, 1,  k) - s1k * a(i, 1, kc)
                    y1p = c1k * a(i, 1, kc) + s1k * a(i, 1,  k)
                    x2p = c2k * a(i, 2,  k) - s2k * a(i, 2, kc)
                    y2p = c2k * a(i, 2, kc) + s2k * a(i, 2,  k)
                    x3p = c3k * a(i, 3,  k) - s3k * a(i, 3, kc)
                    y3p = c3k * a(i, 3, kc) + s3k * a(i, 3,  k)
                    t1r = a(i, 0, k) + x2p
                    t1i = a(i, 0, kc) + y2p
                    t2r = x1p + x3p
                    t2i = y1p + y3p
                    t3r = a(i, 0, k) - x2p
                    t3i = a(i, 0, kc) - y2p
                    t4r = x3p - x1p
                    t4i = y1p - y3p
                    b(i,  k, 0) = t1r + t2r
                    b(i, kc, 0) = t3r - t4i
                    b(i,  k, 1) = t3r + t4i
                    b(i, kc, 1) = t1r - t2r
                    b(i,  k, 2) = t2i - t1i
                    b(i, kc, 2) = t3i + t4r
                    b(i,  k, 3) = t4r - t3i
                    b(i, kc, 3) = t1i + t2i
                enddo
            enddo
        endif

        !Catch the case k = lv / 2 when lv even:
        if (mod(lv, 2) == 0) then
            lvd2 = lv / 2
            do i = 0, nv - 1
                q1 = rtf12 * (a(i, 1, lvd2) - a(i, 3, lvd2))
                q2 = rtf12 * (a(i, 1, lvd2) + a(i, 3, lvd2))
                b(i, lvd2, 0) = a(i, 0, lvd2) + q1
                b(i, lvd2, 1) = a(i, 0, lvd2) - q1
                b(i, lvd2, 2) = a(i, 2, lvd2) - q2
                b(i, lvd2, 3) = - a(i, 2, lvd2) - q2
            enddo
        endif
    end subroutine

    ! Radix three physical to Hermitian FFT with 'decimation in time'.
    subroutine forrdx3(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:2, 0:lv - 1) &
                                         , b(0:nv - 1, 0:lv - 1, 0:2) &
                                         , cosine(0:lv - 1, 1:2)      &
                                         , sine(0:lv - 1, 1:2)
        double precision                :: x1p, x2p, y1p, y2p
        double precision                :: s1k, s2k, c1k, c2k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            t1r = a(i, 1, 0) + a(i, 2, 0)
            b(i, 0, 0) = a(i, 0, 0) + t1r
            b(i, 0, 1) = a(i, 0, 0) - f12 * t1r
            b(i, 0, 2) = sinfpi3 * (a(i, 2, 0) - a(i, 1, 0))
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1p = cosine(k, 1) * a(i, 1,  k) - sine(k, 1) * a(i, 1, kc)
                    y1p = cosine(k, 1) * a(i, 1, kc) + sine(k, 1) * a(i, 1,  k)
                    x2p = cosine(k, 2) * a(i, 2,  k) - sine(k, 2) * a(i, 2, kc)
                    y2p = cosine(k, 2) * a(i, 2, kc) + sine(k, 2) * a(i, 2,  k)
                    t1r = x1p + x2p
                    t1i = y1p + y2p
                    t2r = a(i, 0,  k) - f12 * t1r
                    t2i = f12 * t1i - a(i, 0, kc)
                    t3r = sinfpi3 * (x2p - x1p)
                    t3i = sinfpi3 * (y1p - y2p)
                    b(i,  k, 0) = a(i, 0,  k) + t1r
                    b(i, kc, 0) = t2r - t3i
                    b(i,  k, 1) = t2r + t3i
                    b(i, kc, 1) = t3r - t2i
                    b(i,  k, 2) = t2i + t3r
                    b(i, kc, 2) = a(i, 0, kc) + t1i
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                do i = 0, nv - 1
                    x1p = c1k * a(i, 1,  k) - s1k * a(i, 1, kc)
                    y1p = c1k * a(i, 1, kc) + s1k * a(i, 1,  k)
                    x2p = c2k * a(i, 2,  k) - s2k * a(i, 2, kc)
                    y2p = c2k * a(i, 2, kc) + s2k * a(i, 2,  k)
                    t1r = x1p + x2p
                    t1i = y1p + y2p
                    t2r = a(i, 0,  k) - f12 * t1r
                    t2i = f12 * t1i - a(i, 0, kc)
                    t3r = sinfpi3 * (x2p - x1p)
                    t3i = sinfpi3 * (y1p - y2p)
                    b(i,  k, 0) = a(i, 0,  k) + t1r
                    b(i, kc, 0) = t2r - t3i
                    b(i,  k, 1) = t2r + t3i
                    b(i, kc, 1) = t3r - t2i
                    b(i,  k, 2) = t2i + t3r
                    b(i, kc, 2) = a(i, 0, kc) + t1i
                enddo
            enddo
        endif
    end subroutine

    ! Radix two physical to Hermitian FFT with 'decimation in time'.
    subroutine forrdx2(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:1, 0:lv - 1) &
                                         , b(0:nv - 1, 0:lv - 1, 0:1) &
                                         , cosine(0:lv - 1)           &
                                         , sine(0:lv - 1)
        double precision                :: x1, y1, c1k, s1k
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            b(i, 0, 0) = a(i, 0, 0) + a(i, 1, 0)
            b(i, 0, 1) = a(i, 0, 0) - a(i, 1, 0)
        enddo
        !Next do remaining k:
        if (nv .lt. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1 = cosine(k) * a(i, 1,  k) - sine(k) * a(i, 1, kc)
                    y1 = cosine(k) * a(i, 1, kc) + sine(k) * a(i, 1,  k)
                    b(i,  k, 0) = a(i, 0,  k) + x1
                    b(i, kc, 0) = a(i, 0,  k) - x1
                    b(i,  k, 1) = y1 - a(i, 0, kc)
                    b(i, kc, 1) = a(i, 0, kc) + y1
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k)
                s1k = sine(k)
                do i = 0, nv - 1
                    x1 = c1k * a(i, 1,  k) - s1k * a(i, 1, kc)
                    y1 = c1k * a(i, 1, kc) + s1k * a(i, 1,  k)
                    b(i,  k, 0) = a(i, 0,  k) + x1
                    b(i, kc, 0) = a(i, 0,  k) - x1
                    b(i,  k, 1) = y1 - a(i, 0, kc)
                    b(i, kc, 1) = a(i, 0, kc) + y1
                enddo
            enddo
        endif
    end subroutine

    !====================================================
    ! Spectral to physical (reverse) routines:
    !====================================================

    !Radix six Hermitian to physical FFT with 'decimation in frequency'.
    subroutine revrdx6(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:lv - 1, 0:5) &
                                         , b(0:nv - 1, 0:5, 0:lv - 1) &
                                         , cosine(0:lv - 1, 1:5)      &
                                         , sine(0:lv - 1, 1:5)
        double precision                :: x1p, x2p, x3p, x4p, x5p
        double precision                :: y1p, y2p, y3p, y4p, y5p
        double precision                :: s1k, s2k, s3k, s4k, s5k
        double precision                :: c1k, c2k, c3k, c4k, c5k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r
        double precision                :: u0i, u0r, u1i, u1r, u2i, u2r
        double precision                :: v0i, v0r, v1i, v1r, v2i, v2r
        double precision                :: q1, q2, q3, q4, q5, q6
        integer                         :: i, k, kc, lvd2

        !Do k = 0 first:
        do i = 0, nv - 1
            t2r = a(i, 0, 0) - f12 * a(i, 0, 2)
            t3r = sinfpi3 * a(i, 0, 4)
            u0r = a(i, 0, 0) + a(i, 0, 2)
            u1r = t2r + t3r
            u2r = t2r - t3r
            t2i = a(i, 0, 3) - f12 * a(i, 0, 1)
            t3i = - sinfpi3 * a(i, 0, 5)
            v0r = a(i, 0, 3) + a(i, 0, 1)
            v1r = t2i + t3i
            v2r = t2i - t3i
            b(i, 0, 0) = u0r + v0r
            b(i, 1, 0) = u1r - v1r
            b(i, 2, 0) = u2r + v2r
            b(i, 3, 0) = u0r - v0r
            b(i, 4, 0) = u1r + v1r
            b(i, 5, 0) = u2r - v2r
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    t1r = a(i,  k, 2) + a(i, kc, 1)
                    t1i = a(i, kc, 3) - a(i,  k, 4)
                    t2r = a(i,  k, 0) - f12 * t1r
                    t2i = a(i, kc, 5) - f12 * t1i
                    t3r = sinfpi3 * (a(i,  k, 2) - a(i, kc, 1))
                    t3i = sinfpi3 * (a(i, kc, 3) + a(i,  k, 4))
                    u0r = a(i,  k, 0) + t1r
                    u0i = a(i, kc, 5) + t1i
                    u1r = t2r + t3i
                    u1i = t2i - t3r
                    u2r = t2r - t3i
                    u2i = t2i + t3r
                    t1r = a(i, kc, 0) + a(i, k, 1)
                    t1i = a(i, kc, 4) - a(i, k, 5)
                    t2r = a(i, kc, 2) - f12 * t1r
                    t2i = - a(i, k, 3) - f12 * t1i
                    t3r = sinfpi3 * (a(i, kc, 0) - a(i,  k, 1))
                    t3i = sinfpi3 * ( - a(i, k, 5) - a(i, kc, 4))
                    v0r = a(i, kc, 2) + t1r
                    v0i = t1i - a(i, k, 3)
                    v1r = t2r + t3i
                    v1i = t2i - t3r
                    v2r = t2r - t3i
                    v2i = t2i + t3r
                    x1p = u1r - v1r
                    y1p = u1i - v1i
                    x2p = u2r + v2r
                    y2p = u2i + v2i
                    x3p = u0r - v0r
                    y3p = u0i - v0i
                    x4p = u1r + v1r
                    y4p = u1i + v1i
                    x5p = u2r - v2r
                    y5p = u2i - v2i
                    b(i, 0,  k) = u0r + v0r
                    b(i, 0, kc) = u0i + v0i
                    b(i, 1,  k) = cosine(k, 1) * x1p - sine(k, 1) * y1p
                    b(i, 1, kc) = cosine(k, 1) * y1p + sine(k, 1) * x1p
                    b(i, 2,  k) = cosine(k, 2) * x2p - sine(k, 2) * y2p
                    b(i, 2, kc) = cosine(k, 2) * y2p + sine(k, 2) * x2p
                    b(i, 3,  k) = cosine(k, 3) * x3p - sine(k, 3) * y3p
                    b(i, 3, kc) = cosine(k, 3) * y3p + sine(k, 3) * x3p
                    b(i, 4,  k) = cosine(k, 4) * x4p - sine(k, 4) * y4p
                    b(i, 4, kc) = cosine(k, 4) * y4p + sine(k, 4) * x4p
                    b(i, 5,  k) = cosine(k, 5) * x5p - sine(k, 5) * y5p
                    b(i, 5, kc) = cosine(k, 5) * y5p + sine(k, 5) * x5p
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                c4k = cosine(k, 4)
                s4k = sine(k, 4)
                c5k = cosine(k, 5)
                s5k = sine(k, 5)
                do i = 0, nv - 1
                    t1r = a(i,  k, 2) + a(i, kc, 1)
                    t1i = a(i, kc, 3) - a(i,  k, 4)
                    t2r = a(i,  k, 0) - f12 * t1r
                    t2i = a(i, kc, 5) - f12 * t1i
                    t3r = sinfpi3 * (a(i,  k, 2) - a(i, kc, 1))
                    t3i = sinfpi3 * (a(i, kc, 3) + a(i,  k, 4))
                    u0r = a(i,  k, 0) + t1r
                    u0i = a(i, kc, 5) + t1i
                    u1r = t2r + t3i
                    u1i = t2i - t3r
                    u2r = t2r - t3i
                    u2i = t2i + t3r
                    t1r = a(i, kc, 0) + a(i, k, 1)
                    t1i = a(i, kc, 4) - a(i, k, 5)
                    t2r = a(i, kc, 2) - f12 * t1r
                    t2i = - a(i, k, 3) - f12 * t1i
                    t3r = sinfpi3 * (a(i, kc, 0) - a(i,  k, 1))
                    t3i = sinfpi3 * ( - a(i, k, 5) - a(i, kc, 4))
                    v0r = a(i, kc, 2) + t1r
                    v0i = t1i - a(i, k, 3)
                    v1r = t2r + t3i
                    v1i = t2i - t3r
                    v2r = t2r - t3i
                    v2i = t2i + t3r
                    x1p = u1r - v1r
                    y1p = u1i - v1i
                    x2p = u2r + v2r
                    y2p = u2i + v2i
                    x3p = u0r - v0r
                    y3p = u0i - v0i
                    x4p = u1r + v1r
                    y4p = u1i + v1i
                    x5p = u2r - v2r
                    y5p = u2i - v2i
                    b(i, 0,  k) = u0r + v0r
                    b(i, 0, kc) = u0i + v0i
                    b(i, 1,  k) = c1k * x1p - s1k * y1p
                    b(i, 1, kc) = c1k * y1p + s1k * x1p
                    b(i, 2,  k) = c2k * x2p - s2k * y2p
                    b(i, 2, kc) = c2k * y2p + s2k * x2p
                    b(i, 3,  k) = c3k * x3p - s3k * y3p
                    b(i, 3, kc) = c3k * y3p + s3k * x3p
                    b(i, 4,  k) = c4k * x4p - s4k * y4p
                    b(i, 4, kc) = c4k * y4p + s4k * x4p
                    b(i, 5,  k) = c5k * x5p - s5k * y5p
                    b(i, 5, kc) = c5k * y5p + s5k * x5p
                enddo
            enddo
        endif

        !Catch the case k = lv / 2 when lv even:
        if (mod(lv, 2) == 0) then
            lvd2 = lv / 2
            do i = 0, nv - 1
                q1 = a(i, lvd2, 0) + a(i, lvd2, 2)
                q2 = a(i, lvd2, 5) + a(i, lvd2, 3)
                q3 = a(i, lvd2, 1) - f12 * q1
                q4 = a(i, lvd2, 4) + f12 * q2
                q5 = sinfpi3 * (a(i, lvd2, 0) - a(i, lvd2, 2))
                q6 = sinfpi3 * (a(i, lvd2, 5) - a(i, lvd2, 3))
                b(i, 0, lvd2) = a(i, lvd2, 1) + q1
                b(i, 1, lvd2) = q4 + q5
                b(i, 2, lvd2) = q6 - q3
                b(i, 3, lvd2) = q2 - a(i, lvd2, 4)
                b(i, 4, lvd2) = q3 + q6
                b(i, 5, lvd2) = q4 - q5
            enddo
        endif
    end subroutine

    ! Radix five Hermitian to physical FFT with 'decimation in frequency'.
    subroutine revrdx5(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:lv - 1, 0:4) &
                                         , b(0:nv - 1, 0:4, 0:lv - 1) &
                                         , cosine(0:lv - 1, 1:4)      &
                                         , sine(0:lv - 1, 1:4)
        double precision                :: x1p, x2p, x3p, x4p, y1p, y2p, y3p, y4p
        double precision                :: s1k, s2k, s3k, s4k, c1k, c2k, c3k, c4k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r, t4i, t4r, t5i, t5r, t6i, t6r
        double precision                :: t7i, t7r, t8i, t8r, t9i, t9r, t10i, t10r, t11i, t11r
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            t3r = sinf2pi5 * a(i, 0, 4)
            t4r = sinf2pi5 * a(i, 0, 3)
            t5r = a(i, 0, 1) + a(i, 0, 2)
            t6r = rtf516 * (a(i, 0, 1) - a(i, 0, 2))
            t7r = a(i, 0, 0) - f14 * t5r
            t8r = t7r + t6r
            t9r = t7r - t6r
            t10r = t3r + sinrat * t4r
            t11r = sinrat * t3r - t4r
            b(i, 0, 0) = a(i, 0, 0) + t5r
            b(i, 1, 0) = t8r + t10r
            b(i, 2, 0) = t9r + t11r
            b(i, 3, 0) = t9r - t11r
            b(i, 4, 0) = t8r - t10r
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    t1r = a(i,  k, 1) + a(i, kc, 0)
                    t1i = a(i, kc, 3) - a(i,  k, 4)
                    t2r = a(i,  k, 2) + a(i, kc, 1)
                    t2i = a(i, kc, 2) - a(i,  k, 3)
                    t3r = sinf2pi5 * (a(i,  k, 1) - a(i, kc, 0))
                    t3i = sinf2pi5 * (a(i, kc, 3) + a(i,  k, 4))
                    t4r = sinf2pi5 * (a(i,  k, 2) - a(i, kc, 1))
                    t4i = sinf2pi5 * (a(i, kc, 2) + a(i,  k, 3))
                    t5r = t1r + t2r
                    t5i = t1i + t2i
                    t6r = rtf516 * (t1r - t2r)
                    t6i = rtf516 * (t1i - t2i)
                    t7r = a(i, k, 0) - f14 * t5r
                    t7i = a(i, kc, 4) - f14 * t5i
                    t8r = t7r + t6r
                    t8i = t7i + t6i
                    t9r = t7r - t6r
                    t9i = t7i - t6i
                    t10r = t3r + sinrat * t4r
                    t10i = t3i + sinrat * t4i
                    t11r = sinrat * t3r - t4r
                    t11i = sinrat * t3i - t4i
                    x1p = t8r + t10i
                    y1p = t8i - t10r
                    x2p = t9r + t11i
                    y2p = t9i - t11r
                    x3p = t9r - t11i
                    y3p = t9i + t11r
                    x4p = t8r - t10i
                    y4p = t8i + t10r
                    b(i, 0,  k) = a(i,  k, 0) + t5r
                    b(i, 0, kc) = a(i, kc, 4) + t5i
                    b(i, 1,  k) = cosine(k, 1) * x1p - sine(k, 1) * y1p
                    b(i, 1, kc) = cosine(k, 1) * y1p + sine(k, 1) * x1p
                    b(i, 2,  k) = cosine(k, 2) * x2p - sine(k, 2) * y2p
                    b(i, 2, kc) = cosine(k, 2) * y2p + sine(k, 2) * x2p
                    b(i, 3,  k) = cosine(k, 3) * x3p - sine(k, 3) * y3p
                    b(i, 3, kc) = cosine(k, 3) * y3p + sine(k, 3) * x3p
                    b(i, 4,  k) = cosine(k, 4) * x4p - sine(k, 4) * y4p
                    b(i, 4, kc) = cosine(k, 4) * y4p + sine(k, 4) * x4p
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                c4k = cosine(k, 4)
                s4k = sine(k, 4)
                do i = 0, nv - 1
                    t1r = a(i,  k, 1) + a(i, kc, 0)
                    t1i = a(i, kc, 3) - a(i,  k, 4)
                    t2r = a(i,  k, 2) + a(i, kc, 1)
                    t2i = a(i, kc, 2) - a(i,  k, 3)
                    t3r = sinf2pi5 * (a(i,  k, 1) - a(i, kc, 0))
                    t3i = sinf2pi5 * (a(i, kc, 3) + a(i,  k, 4))
                    t4r = sinf2pi5 * (a(i,  k, 2) - a(i, kc, 1))
                    t4i = sinf2pi5 * (a(i, kc, 2) + a(i,  k, 3))
                    t5r = t1r + t2r
                    t5i = t1i + t2i
                    t6r = rtf516 * (t1r - t2r)
                    t6i = rtf516 * (t1i - t2i)
                    t7r = a(i, k, 0) - f14 * t5r
                    t7i = a(i, kc, 4) - f14 * t5i
                    t8r = t7r + t6r
                    t8i = t7i + t6i
                    t9r = t7r - t6r
                    t9i = t7i - t6i
                    t10r = t3r + sinrat * t4r
                    t10i = t3i + sinrat * t4i
                    t11r = sinrat * t3r - t4r
                    t11i = sinrat * t3i - t4i
                    x1p = t8r + t10i
                    y1p = t8i - t10r
                    x2p = t9r + t11i
                    y2p = t9i - t11r
                    x3p = t9r - t11i
                    y3p = t9i + t11r
                    x4p = t8r - t10i
                    y4p = t8i + t10r
                    b(i, 0,  k) = a(i,  k, 0) + t5r
                    b(i, 0, kc) = a(i, kc, 4) + t5i
                    b(i, 1,  k) = c1k * x1p - s1k * y1p
                    b(i, 1, kc) = c1k * y1p + s1k * x1p
                    b(i, 2,  k) = c2k * x2p - s2k * y2p
                    b(i, 2, kc) = c2k * y2p + s2k * x2p
                    b(i, 3,  k) = c3k * x3p - s3k * y3p
                    b(i, 3, kc) = c3k * y3p + s3k * x3p
                    b(i, 4,  k) = c4k * x4p - s4k * y4p
                    b(i, 4, kc) = c4k * y4p + s4k * x4p
                enddo
            enddo
        endif
    end subroutine

    !Radix four Hermitian to physical FFT with 'decimation in frequency'.
    subroutine revrdx4(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:lv - 1, 0:3) &
                                         , b(0:nv - 1, 0:3, 0:lv - 1) &
                                         , cosine(0:lv - 1, 1:3)      &
                                         , sine(0:lv - 1, 1:3)
        double precision                :: x1p, x2p, x3p, y1p, y2p, y3p
        double precision                :: s1k, s2k, s3k, c1k, c2k, c3k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r, t4i, t4r
        integer                         :: i, k, kc, lvd2

        !Do k = 0 first:
        do i = 0, nv - 1
            t1r = a(i, 0, 0) + a(i, 0, 2)
            t2r = a(i, 0, 1)
            t3r = a(i, 0, 0) - a(i, 0, 2)
            t4r = a(i, 0, 3)
            b(i, 0, 0) = t1r + t2r
            b(i, 1, 0) = t3r + t4r
            b(i, 2, 0) = t1r - t2r
            b(i, 3, 0) = t3r - t4r
        enddo
        !Next do remaining k:
        if (nv .lt. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    t1r = a(i,  k, 0) + a(i, kc, 1)
                    t1i = a(i, kc, 3) - a(i,  k, 2)
                    t2r = a(i,  k, 1) + a(i, kc, 0)
                    t2i = a(i, kc, 2) - a(i,  k, 3)
                    t3r = a(i,  k, 0) - a(i, kc, 1)
                    t3i = a(i, kc, 3) + a(i,  k, 2)
                    t4r = a(i,  k, 1) - a(i, kc, 0)
                    t4i = a(i, kc, 2) + a(i,  k, 3)
                    x1p = t3r + t4i
                    y1p = t3i - t4r
                    x2p = t1r - t2r
                    y2p = t1i - t2i
                    x3p = t3r - t4i
                    y3p = t3i + t4r
                    b(i, 0,  k) = t1r + t2r
                    b(i, 0, kc) = t1i + t2i
                    b(i, 1,  k) = cosine(k, 1) * x1p - sine(k, 1) * y1p
                    b(i, 1, kc) = cosine(k, 1) * y1p + sine(k, 1) * x1p
                    b(i, 2,  k) = cosine(k, 2) * x2p - sine(k, 2) * y2p
                    b(i, 2, kc) = cosine(k, 2) * y2p + sine(k, 2) * x2p
                    b(i, 3,  k) = cosine(k, 3) * x3p - sine(k, 3) * y3p
                    b(i, 3, kc) = cosine(k, 3) * y3p + sine(k, 3) * x3p
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                c3k = cosine(k, 3)
                s3k = sine(k, 3)
                do i = 0, nv - 1
                    t1r = a(i, k, 0) + a(i, kc, 1)
                    t1i = a(i, kc, 3) - a(i, k, 2)
                    t2r = a(i, k, 1) + a(i, kc, 0)
                    t2i = a(i, kc, 2) - a(i, k, 3)
                    t3r = a(i, k, 0) - a(i, kc, 1)
                    t3i = a(i, kc, 3) + a(i, k, 2)
                    t4r = a(i, k, 1) - a(i, kc, 0)
                    t4i = a(i, kc, 2) + a(i, k, 3)
                    x1p = t3r + t4i
                    y1p = t3i - t4r
                    x2p = t1r - t2r
                    y2p = t1i - t2i
                    x3p = t3r - t4i
                    y3p = t3i + t4r
                    b(i, 0,  k) = t1r + t2r
                    b(i, 0, kc) = t1i + t2i
                    b(i, 1,  k) = c1k * x1p - s1k * y1p
                    b(i, 1, kc) = c1k * y1p + s1k * x1p
                    b(i, 2,  k) = c2k * x2p - s2k * y2p
                    b(i, 2, kc) = c2k * y2p + s2k * x2p
                    b(i, 3,  k) = c3k * x3p - s3k * y3p
                    b(i, 3, kc) = c3k * y3p + s3k * x3p
                enddo
            enddo
        endif

        !Catch the case k = lv / 2 when lv even:
        if (mod(lv, 2) == 0) then
            lvd2 = lv / 2
            do i = 0, nv - 1
                b(i, 0, lvd2) = a(i, lvd2, 0) + a(i, lvd2, 1)
                b(i, 2, lvd2) = a(i, lvd2, 3) - a(i, lvd2, 2)
                t3r = a(i, lvd2, 0) - a(i, lvd2, 1)
                t4r = a(i, lvd2, 3) + a(i, lvd2, 2)
                b(i, 1, lvd2) = rtf12 * (t3r + t4r)
                b(i, 3, lvd2) = rtf12 * (t4r - t3r)
            enddo
        endif
    end subroutine

    !Radix three Hermitian to physical FFT with 'decimation in frequency'.
    subroutine revrdx3(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:lv - 1, 0:2) &
                                         , b(0:nv - 1, 0:2, 0:lv - 1) &
                                         , cosine(0:lv - 1, 1:2)      &
                                         , sine(0:lv - 1, 1:2)
        double precision                :: x1p, x2p, y1p, y2p
        double precision                :: c2k, c1k, s2k, s1k
        double precision                :: t1i, t1r, t2i, t2r, t3i, t3r
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            t1r = a(i, 0, 1)
            t2r = a(i, 0, 0) - f12 * t1r
            t3r = sinfpi3 * a(i, 0, 2)
            b(i, 0, 0) = a(i, 0, 0) + t1r
            b(i, 1, 0) = t2r + t3r
            b(i, 2, 0) = t2r - t3r
        enddo
        !Next do remaining k:
        if (nv .le. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    t1r = a(i,  k, 1) + a(i, kc, 0)
                    t1i = a(i, kc, 1) - a(i,  k, 2)
                    t2r = a(i,  k, 0) - f12 * t1r
                    t2i = a(i, kc, 2) - f12 * t1i
                    t3r = sinfpi3 * (a(i,  k, 1) - a(i, kc, 0))
                    t3i = sinfpi3 * (a(i, kc, 1) + a(i,  k, 2))
                    x1p = t2r + t3i
                    y1p = t2i - t3r
                    x2p = t2r - t3i
                    y2p = t2i + t3r
                    b(i, 0,  k) = a(i,  k, 0) + t1r
                    b(i, 0, kc) = a(i, kc, 2) + t1i
                    b(i, 1,  k) = cosine(k, 1) * x1p - sine(k, 1) * y1p
                    b(i, 1, kc) = sine(k, 1) * x1p + cosine(k, 1) * y1p
                    b(i, 2,  k) = cosine(k, 2) * x2p - sine(k, 2) * y2p
                    b(i, 2, kc) = sine(k, 2) * x2p + cosine(k, 2) * y2p
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k, 1)
                s1k = sine(k, 1)
                c2k = cosine(k, 2)
                s2k = sine(k, 2)
                do i = 0, nv - 1
                    t1r = a(i,  k, 1) + a(i, kc, 0)
                    t1i = a(i, kc, 1) - a(i,  k, 2)
                    t2r = a(i,  k, 0) - f12 * t1r
                    t2i = a(i, kc, 2) - f12 * t1i
                    t3r = sinfpi3 * (a(i,  k, 1) - a(i, kc, 0))
                    t3i = sinfpi3 * (a(i, kc, 1) + a(i,  k, 2))
                    x1p = t2r + t3i
                    y1p = t2i - t3r
                    x2p = t2r - t3i
                    y2p = t2i + t3r
                    b(i, 0,  k) = a(i,  k, 0) + t1r
                    b(i, 0, kc) = a(i, kc, 2) + t1i
                    b(i, 1,  k) = c1k * x1p - s1k * y1p
                    b(i, 1, kc) = s1k * x1p + c1k * y1p
                    b(i, 2,  k) = c2k * x2p - s2k * y2p
                    b(i, 2, kc) = s2k * x2p + c2k * y2p
                enddo
            enddo
        endif
    end subroutine

    !Radix two Hermitian to physical FFT with 'decimation in frequency'.
    subroutine revrdx2(a, b, nv, lv, cosine, sine)
        integer,          intent(in)    :: nv, lv
        double precision, intent(inout) :: a(0:nv - 1, 0:lv - 1, 0:1) &
                                         , b(0:nv - 1, 0:1, 0:lv - 1) &
                                         , cosine(0:lv - 1)           &
                                         , sine(0:lv - 1)
        double precision                :: x1p, y1p, c1k, s1k
        integer                         :: i, k, kc

        !Do k = 0 first:
        do i = 0, nv - 1
            b(i, 0, 0) = a(i, 0, 0) + a(i, 0, 1)
            b(i, 1, 0) = a(i, 0, 0) - a(i, 0, 1)
        enddo
        !Next do remaining k:
        if (nv .lt. (lv - 1) / 2) then
            do i = 0, nv - 1
                do k = 1, (lv - 1) / 2
                    kc = lv - k
                    x1p = a(i,  k, 0) - a(i, kc, 0)
                    y1p = a(i, kc, 1) + a(i,  k, 1)
                    b(i, 0,  k) = a(i,  k, 0) + a(i, kc, 0)
                    b(i, 0, kc) = a(i, kc, 1) - a(i,  k, 1)
                    b(i, 1,  k) = cosine(k) * x1p - sine(k) * y1p
                    b(i, 1, kc) = cosine(k) * y1p + sine(k) * x1p
                enddo
            enddo
        else
            do k = 1, (lv - 1) / 2
                kc = lv - k
                c1k = cosine(k)
                s1k = sine(k)
                do i = 0, nv - 1
                    x1p = a(i,  k, 0) - a(i, kc, 0)
                    y1p = a(i, kc, 1) + a(i,  k, 1)
                    b(i, 0,  k) = a(i,  k, 0) + a(i, kc, 0)
                    b(i, 0, kc) = a(i, kc, 1) - a(i,  k, 1)
                    b(i, 1,  k) = c1k * x1p - s1k * y1p
                    b(i, 1, kc) = c1k * y1p + s1k * x1p
                enddo
            enddo
        endif
    end subroutine
end module


      SUBROUTINE fftrig_g (trigs, n, mode)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER n, mode
      REAL(rprec), DIMENSION(*) :: trigs
!DEC$ IF .NOT.DEFINED (CRAY) .OR. DEFINED(LONESTAR) .OR. DEFINED(MCURIE)
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, two = 2, p5 = 0.5_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: imode, nn, l, i, nh, la
      REAL(rprec) :: pi, del, angle
C-----------------------------------------------
      pi=two*ASIN(one)
      imode=IABS(mode)
      nn=n
      IF (imode.gt.1.and.imode.lt.6) nn=n/2
      del=(pi+pi)/nn
      l=nn+nn
      DO 10 i=1,l,2
      angle=(p5*del)*(i-1)
      trigs(i)=COS(angle)
      trigs(i+1)=SIN(angle)
   10 CONTINUE
      IF (imode.eq.1) RETURN
      IF (imode.eq.8) RETURN
      del=del/2
      nh=(nn+1)/2
      l=nh+nh
      la=nn+nn
      DO 20 i=1,l,2
      angle=(i-1)*(del/2)
      trigs(la+i)=COS(angle)
      trigs(la+i+1)=SIN(angle)
   20 CONTINUE
      IF (imode.le.3) RETURN
      del=del/2
      la=la+nn
      IF (mode.eq.5) GOTO 40
      DO 30 i=2,nn
      angle=(i-1)*del
      trigs(la+i)=two*SIN(angle)
   30 CONTINUE
      RETURN
   40 CONTINUE
      del=del/2
      DO 50 i=2,n
      angle = (i-1)*del
      trigs(la+i)=SIN(angle)
   50 CONTINUE
!DEC$ ELSE
      CALL fftrig (trigs, n, mode)
!DEC$ ENDIF
      END SUBROUTINE fftrig_g


!-----------------------------------------------------------------------
!     Function:      db_simpson
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/02/2012
!     Description:   This subroutine calculates the field due to a line
!                    segment using simpson formula.
!-----------------------------------------------------------------------
      REAL FUNCTION db_simpson(x0,y0,z0,x1,y1,z1,cg,ldb)
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE virtual_casing_mod
      USE biotsavart
      USE bsc_T
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER, intent(in) :: cg
      REAL(rprec)   , intent(in) :: x0,y0,z0,x1,y1,z1
      LOGICAL, intent(in), optional :: ldb
      LOGICAL     :: ldb_local
      REAL(rprec) :: delf,delt,dx,dy,dz,xp,yp,zp,bx,by,bz,dl
      REAL(rprec) :: xvec(3),bvec(3)
      INTEGER     :: i,ier
      integer, parameter :: nop=3
      real(rprec), dimension(nop), parameter :: ci=(/1./6.,2./3.,1./6./)
!-----------------------------------------------------------------------
!     Begin Function
!-----------------------------------------------------------------------

      delf = 0
      delt = REAL(1)/REAL(nop-1)
      dx = x1-x0
      dy = y1-y0
      dz = z1-z0
      dl = 1
      ldb_local=.false.
      IF (cg > 0) THEN
         DO i = 1, nop
            xvec(1) = x0+(i-1)*dx*delt
            xvec(2) = y0+(i-1)*dy*delt
            xvec(3) = z0+(i-1)*dz*delt
            CALL bsc_b(coil_group(cg),xvec,bvec)
            delf = delf+ ci(i)*(bvec(1)*dx+bvec(2)*dy+bvec(3)*dz)
         END DO
      ELSE
         DO i = 1, nop
            ier = 1; bx = 0.0; by = 0.0; bz = 0.0
            xp = x0+(i-1)*dx*delt
            yp = y0+(i-1)*dy*delt
            zp = z0+(i-1)*dz*delt
            CALL bfield_vc(xp,yp,zp,bx,by,bz,ier)
            delf = delf+ ci(i)*(bx*dx+by*dy+bz*dz)
         END DO
      END IF
      IF (ldb_local) THEN
         dl = 0.0
         DO i = 1, nop
            xp = x0+(i-1)*dx*delt
            yp = y0+(i-1)*dy*delt
            zp = z0+(i-1)*dz*delt
            dl = dl+ ci(i)*SQRT(dx*dx+dy*dy+dz*dz)
         END DO
      END IF
      db_simpson = delf/dl
      RETURN
!-----------------------------------------------------------------------
!     End Function
!-----------------------------------------------------------------------
      END FUNCTION db_simpson


	SUBROUTINE GITOG  ( np, xm, ym, xg, yg, iret )
C************************************************************************
C* GITOG								*
C* 									*
C* This subroutine converts points in the grid linear intermediate	*
C* coordinate system into grid coordinates.				*
C* 									*
C* GITOG  ( NP, XM, YM, XG, YG, IRET )					*
C* 									*
C* Input parameters:							*
C*	NP		INTEGER		Number of points		*
C* 	XM (NP)		REAL		X input coordinates		*
C*	YM (NP)		REAL		Y input coordinates		*
C*									*
C* Output parameters:							*
C*	XG (NP)		REAL		X output coordinates		*
C* 	YG (NP)		REAL		Y output coordinates		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	6/86	Corrected names of scaling terms for	*
C*				graph transformations			*
C* M. desJardins/GSFC	10/86	Added polar coordinate system		*
C* M. desJardins/GSFC	 2/87	Corrected polar coord when graph not set*
C* M. desJardins/GSFC	 1/88	Missing data fix			*
C* M. desJardins/GSFC	 6/88	Adapted from GMTOG			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'XYDEF.CMN'
C*
	REAL		xm (*), ym (*), xg (*), yg (*)
C*
	INCLUDE		'ERMISS.FNC'
C-------------------------------------------------------------------------
C*	Convert linear intermediate to grid coordinates.
C
	IF  ( ( igmode .eq. 1 ) .and. ( mgset ) )  THEN
	    DO  i = 1, np
		IF  ( ( .not. ERMISS ( xm (i) ) ) .and.
     +		      ( .not. ERMISS ( ym (i) ) ) )  THEN
		    xg (i) = ( xm (i) - aglx0 ) / aglx1
		    yg (i) = ( ym (i) - agly0 ) / agly1
		END IF
	    END DO
C*
	  ELSE IF  ( ( igmode .eq. 2 ) .and. ( ggset ) )  THEN
	    DO  i = 1, np
		IF  ( ( .not. ERMISS ( xm (i) ) ) .and.
     +		      ( .not. ERMISS ( ym (i) ) ) )  THEN
		    xg (i) = ( xm (i) - gxx0 ) / gxx1
		    yg (i) = ( ym (i) - gyy0 ) / gyy1
		END IF
	    END DO
C*
	  ELSE
	    iret = NIPROJ
	END IF
C*
	RETURN
	END


module qutraj_linalg
  !
  ! This module depends on LAPACK
  !

  use qutraj_precision
  use qutraj_general
  use qutraj_hilbert

  implicit none

  contains

  subroutine eigenvalues(rho,eig,n)
    ! Eigenvalues of dense hermitian matrix rho
    complex(wp), intent(in) :: rho(:,:)
    integer, intent(in) :: n
    real(wp), intent(out) :: eig(n)
    double complex :: ap(n*(n+1)/2), z(1,1),work(2*n-1)
    double precision :: eig_dp(n),rwork(3*n-2)
    integer info,i,j
    do i=1,n
      do j=i,n
        ap(i+(j-1)*j/2) = rho(i,j)
      enddo
    enddo
    call zhpev('N','U',n,ap,eig_dp,z,1,work,rwork,info)
    eig = eig_dp
  end subroutine

  subroutine entropy(rho,S)
    ! Calculate entropy for dense density matrix
    complex(wp), intent(in) :: rho(:,:)
    real(wp), intent(out) :: S
    real(wp), dimension(2) :: eig_r
    integer :: i
    call eigenvalues(rho,eig_r,size(rho,1))
    S = 0
    do i=1,size(eig_r)
      ! Rule: 0 log(0) = 0
      if (eig_r(i) < -epsi) &
        write(*,*) "entropy: negative eigenvalue!", eig_r(i)
      if (abs(eig_r(i)) > epsi) then
        S = S -eig_r(i)*log(eig_r(i))/log(2.)
      endif
    enddo
  end subroutine

end module


module spherePEC_mod
    use pec_scattering
    use data_tools
    use meshread_mod
    implicit none

    private :: PI

contains
    ! Computes the source field due to a incident plane wave at
    ! a PEC half-sphere on top of an infinite PEC plane
    subroutine halfsphere_on_plane_source_field(alpha, k, msh, Esrc, TE_mode)
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        real(8), intent(in) :: k               ! wavenumber [1/m]
        type(Mesh), intent(in) :: msh          ! Mesh object
        logical, intent(in) :: TE_mode         ! .true.=TE, .false.=TM
        complex(8), allocatable, intent(out) :: Esrc(:, :) ! Source electric field on mesh, in V/m

        real(8) :: msh_nodes(3, msh%nbNod)
        complex(8) :: amplitude
        complex(8), allocatable :: Einc_transposed(:, :)
        complex(8), allocatable :: Einc_mirror_transposed(:, :)

        ! it's necessary to transpose the data
        ! because the 'arrays orientation convention'
        ! between modules is different
        msh_nodes = transpose(msh%POS)

        ! compute incident plane wave
        ! and mirror incident plane wave,
        ! of unit amplitude
        amplitude = 1d0
        if (TE_mode) then
            call incident_plane_wave_TE(msh_nodes, k, alpha, amplitude, Einc_transposed)
            call incident_plane_wave_TE(msh_nodes, k, -alpha, -amplitude, Einc_mirror_transposed)
        else
            call incident_plane_wave_TM(msh_nodes, k, alpha, amplitude, Einc_transposed)
            call incident_plane_wave_TM(msh_nodes, k, -alpha, amplitude, Einc_mirror_transposed)
        end if

        ! transpose the data again
        ! and apply complex conjugated
        ! to obtain a field with exp(-jw)
        ! harmonic time dependence
        allocate(Esrc(msh%nbNod, 3))
        Esrc = conjg(transpose(Einc_transposed + Einc_mirror_transposed))
    end subroutine

    ! Computes the scattered field due to a incident plane wave at
    ! a PEC half-sphere on top of an infinite PEC plane
    subroutine halfsphere_on_plane_scattered_field(xEvl, k, a, alpha, n_terms, Es_list, TE_mode)
        real(8), intent(in) :: xEvl(:, :)      ! list of points = [x1, x2, .. ; y1, y2, .. ;z1, z2, ..]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        logical, intent(in) :: TE_mode         ! .true.=TE, .false.=TM
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! total scattered electric field in V/m

        real(8) :: xEvl_transposed(size(xEvl, 2), size(xEvl, 1))
        complex(8) :: amplitude
        complex(8), allocatable :: Es_transposed(:, :)
        complex(8), allocatable :: Es_mirror_transposed(:, :)

        ! it's necessary to transpose the data
        ! because the 'arrays orientation convention'
        ! between modules is different
        xEvl_transposed = transpose(xEvl)

        ! compute scattered field and
        ! mirror scattered field by
        ! a plane wave of unit amplitude
        amplitude = 1d0
        if (TE_mode) then
            call sphere_scattering(xEvl_transposed, k, a, alpha, amplitude, n_terms, .true., Es_transposed)
            call sphere_scattering(xEvl_transposed, k, a, -alpha, -amplitude, n_terms, .true., Es_mirror_transposed)
        else
            call sphere_scattering(xEvl_transposed, k, a, alpha, amplitude, n_terms, .false., Es_transposed)
            call sphere_scattering(xEvl_transposed, k, a, -alpha, amplitude, n_terms, .false., Es_mirror_transposed)
        end if

        ! transpose the data again
        ! and apply complex conjugated
        ! to obtain a field with exp(-jw)
        ! harmonic time dependence
        allocate(Es_list(size(xEvl, 1), size(xEvl, 2)))
        Es_list = conjg(transpose(Es_transposed + Es_mirror_transposed))
    end subroutine

    ! Computes the scattered field due to a incident plane wave at
    ! a PEC sphere
    subroutine sphere_scattered_field(xEvl, k, a, alpha, Es_list, TE_mode)
        real(8), intent(in) :: xEvl(:, :)      ! list of points = [x1, x2, .. ; y1, y2, .. ;z1, z2, ..]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        logical, intent(in) :: TE_mode         ! .true.=TE, .false.=TM
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! total scattered electric field in V/m
        integer, parameter :: n_terms = 50     ! number of terms in Mie series

        real(8) :: xEvl_transposed(size(xEvl, 2), size(xEvl, 1))
        complex(8) :: amplitude
        complex(8), allocatable :: Es_transposed(:, :)

        ! it's necessary to transpose the data
        ! because the 'arrays orientation convention'
        ! between modules is different
        xEvl_transposed = transpose(xEvl)

        ! compute scattered field and
        ! mirror scattered field by
        ! a plane wave of unit amplitude
        amplitude = 1d0
        if (TE_mode) then
            call sphere_scattering(xEvl_transposed, k, a, alpha, amplitude, n_terms, .true., Es_transposed)
        else
            call sphere_scattering(xEvl_transposed, k, a, alpha, amplitude, n_terms, .false., Es_transposed)
        end if

        ! transpose the data again
        ! and apply complex conjugated
        ! to obtain a field with exp(-jw)
        ! harmonic time dependence
        allocate(Es_list(size(xEvl, 1), size(xEvl, 2)))
        Es_list = conjg(transpose(Es_transposed))
    end subroutine

    ! Computes a plane wave electric field, of unit amplitude,
    ! at the mesh nodes
    subroutine planewave_on_mesh(alpha, k, msh, Einc, TE_mode, Hinc)
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        real(8), intent(in) :: k               ! wavenumber [1/m]
        type(Mesh), intent(in) :: msh          ! Mesh object
        logical, intent(in) :: TE_mode         ! .true.=TE, .false.=TM
        complex(8), allocatable, intent(out) :: Einc(:, :) ! Electric field on mesh, in V/m
        complex(8), allocatable, intent(out), optional :: Hinc(:,:) ! Cross field (k x Einc) on mesh

        real(8) :: msh_nodes(3, msh%nbNod)
        real(8) :: kvec(3)
        integer :: n
        complex(8) :: amplitude
        complex(8), allocatable :: Einc_transposed(:, :)

        ! it's necessary to transpose the data
        ! because the 'arrays orientation convention'
        ! between modules is different
        msh_nodes = transpose(msh%POS)

        ! compute incident plane wave of unit amplitude
        amplitude = 1d0
        if (TE_mode) then
            call incident_plane_wave_TE(msh_nodes, k, alpha, amplitude, Einc_transposed)
        else
            call incident_plane_wave_TM(msh_nodes, k, alpha, amplitude, Einc_transposed)
        end if

        ! transpose the data again
        ! and apply complex conjugated
        ! to obtain a field with exp(-jw)
        ! harmonic time dependence
        allocate(Einc(msh%nbNod, 3))
        Einc = conjg(transpose(Einc_transposed))

        ! compute cross field (k x Einc) if present
        if (present(Hinc)) then
            kvec = [0d0, k*cos(alpha), -k*sin(alpha)]
            allocate(Hinc(msh%nbNod, 3))
            do n = 1, msh%nbNod
                Hinc(n, 1) = kvec(2) * Einc(n, 3) - kvec(3) * Einc(n, 2)
                Hinc(n, 2) = kvec(3) * Einc(n, 1) - kvec(1) * Einc(n, 3)
                Hinc(n, 3) = kvec(1) * Einc(n, 2) - kvec(2) * Einc(n, 1)
            end do
        end if
    end subroutine

    ! Computes the total scattered field by a planewave (unit amplitud)
    ! on a PEC half-sphere on top of an infinite PEC plane.
    subroutine planewave_scattered_field(xEvl, k, a, alpha, n_terms, Es_list, TE_mode)
        real(8), intent(in) :: xEvl(:, :)      ! list of points = [x1, x2, .. ; y1, y2, .. ;z1, z2, ..]
        real(8), intent(in) :: k               ! wavenumber [1/m]
        real(8), intent(in) :: a               ! sphere radius [m]
        real(8), intent(in) :: alpha           ! incidence angle in (0, pi)
        integer, intent(in) :: n_terms         ! number of terms in Mie series
        logical, intent(in) :: TE_mode         ! .true.=TE, .false.=TM
        complex(8), allocatable, intent(out) :: Es_list(:, :) ! total scattered electric field in V/m

        real(8) :: xEvl_transposed(size(xEvl, 2), size(xEvl, 1))
        complex(8) :: amplitude
        complex(8), allocatable :: Es_list_transposed(:, :)

        ! it's necessary to transpose the data
        ! because the 'arrays orientation convention'
        ! between modules is different
        xEvl_transposed = transpose(xEvl)

        ! compute scattered field by a plane wave of unit amplitude
        amplitude = 1d0
        if (TE_mode) then
            call sphere_plane_scattering_TE(xEvl_transposed, k, a, alpha, amplitude, n_terms, Es_list_transposed)
        else
            call sphere_plane_scattering_TM(xEvl_transposed, k, a, alpha, amplitude, n_terms, Es_list_transposed)
        end if

        ! transpose the data again
        ! and apply complex conjugated
        ! to obtain a field with exp(-jw)
        ! harmonic time dependence
        allocate(Es_list(size(xEvl, 1), size(xEvl, 2)))
        Es_list = conjg(transpose(Es_list_transposed))
    end subroutine

end module


! Output all elem's that have area <= a given threshold and all small sides
! Inputs: screen; old.gr3 (any proj)
! Outputs: small_[area, side].bp (add header yourself)
! ifort -Bstatic -O2 -mcmodel=medium -o find_small_elem find_small_elem.f90

  implicit real*8(a-h,o-z)
  allocatable :: xnd(:),ynd(:),area(:),ielnode(:,:),i34(:)

  print*, 'Input a threshold for area:'
  read*, small1

  print*, 'Input a threshold for side length:'
  read*, small2

  open(14,file='old.gr3',status='old')
  open(12,file='small_area.bp',status='replace')
  open(13,file='small_side.bp',status='replace')
  read(14,*); read(14,*)ne,np
  allocate(xnd(np),ynd(np),area(ne),ielnode(4,ne),i34(ne))
  do i=1,np
    read(14,*)j,xnd(i),ynd(i)
  enddo !i
  icount=0
  icount2=0
  write(12,*)'Threshold=',small1
  write(13,*)'Threshold=',small2
  do i=1,ne
    read(14,*)j,i34(i),ielnode(1:i34(i),i)

    n1=ielnode(1,i); n2=ielnode(2,i); n3=ielnode(3,i);
    ar1=signa(xnd(n1),xnd(n2),xnd(n3),ynd(n1),ynd(n2),ynd(n3))
    if(ar1<=0) then
      print*, 'area<=0:',i,ar1
    endif
    area(i)=ar1
    if(i34(i)==3) then
    else if(i34(i)==4) then
      n4=ielnode(4,i)
      ar2=signa(xnd(n1),xnd(n3),xnd(n4),ynd(n1),ynd(n3),ynd(n4))
      if(ar2<=0) then
        print*, 'area<=0(2):',i,ar2
      endif
      area(i)=area(i)+ar2
    else
      stop 'Unknown elem type'
    endif

    if(area(i)<=small1) then
      icount=icount+1
      xctr=sum(xnd(ielnode(1:i34(i),i)))/i34(i)
      yctr=sum(ynd(ielnode(1:i34(i),i)))/i34(i)
      write(12,'(i12,2(1x,e20.12),1x,e12.5,1x,i12)')icount,xctr,yctr,real(area(i)),i
    endif

    !Side length
    do j=1,i34(i)
      j2=j+1
      if(j2>i34(i)) j2=j2-i34(i)
      nd1=ielnode(j,i)
      nd2=ielnode(j2,i)
      rl=sqrt((xnd(nd1)-xnd(nd2))**2+(ynd(nd1)-ynd(nd2))**2)
      if(rl<=small2) then
        icount2=icount2+1
        xj=(xnd(nd1)+xnd(nd2))/2
        yj=(ynd(nd1)+ynd(nd2))/2
        write(13,'(i12,2(1x,e20.12),1x,e12.5,2(1x,i12))')icount2,xj,yj,rl,nd1,nd2
      endif
    enddo !j
  enddo !i=1,ne
  close(14)
  close(13)
  close(12)

  print*, icount,' small elem found; done'
  print*, icount2,' small side found; done'

  stop
  end

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

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

      return
      end


c  Part of R package KernSmooth
c  Copyright (C) 1995  M. P. Wand
c
c  Unlimited use and distribution (see LICENCE).

cccccccccc FORTRAN subroutine linbin2D.f cccccccccc

c Obtains bin counts for bivariate data
c via the linear binning strategy. In this version
c observations outside the mesh are ignored.

      subroutine lbtwod(X,n,a1,a2,b1,b2,M1,M2,gcnts)
      integer n,M1,M2,i,li1,li2,ind1,ind2,ind3,ind4
      double precision X(*),a1,a2,b1,b2,gcnts(*)
      double precision lxi1,lxi2,delta1,delta2,rem1,rem2

c     Initialize grid cnts to zero

      do 10 i = 1,(M1*M2)
         gcnts(i) = dble(0)
10    continue

      delta1 = (b1 - a1)/(M1 - 1)
      delta2 = (b2 - a2)/(M2 - 1)
      do 20 i = 1,n
         lxi1 = ((X(i) - a1)/delta1) + 1
         lxi2 = ((X(n+i) - a2)/delta2) + 1

c        Find the integer part of "lxi1" and "lxi2"

         li1 = int(lxi1)
         li2 = int(lxi2)
         rem1 = lxi1 - li1
         rem2 = lxi2 - li2
         if (li1.ge.1) then
            if (li2.ge.1) then
               if (li1.lt.M1) then
                  if (li2.lt.M2) then
                     ind1 = M1*(li2-1) + li1
                     ind2 = M1*(li2-1) + li1 + 1
                     ind3 = M1*li2 + li1
                     ind4 = M1*li2 + li1 + 1
                     gcnts(ind1) = gcnts(ind1)+(1-rem1)*(1-rem2)
                     gcnts(ind2) = gcnts(ind2)+rem1*(1-rem2)
                     gcnts(ind3) = gcnts(ind3)+(1-rem1)*rem2
                     gcnts(ind4) = gcnts(ind4)+rem1*rem2
                  endif
               endif
            endif
         endif
20    continue

      return
      end

cccccccccc End of linbin2D.f cccccccccc


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
module global_variables

! parameter
  integer,parameter :: dp = kind(0d0), zp = kind((1d0,1d0))
  complex(zp),parameter :: zI = (0d0,1d0)
  real(dp),parameter :: pi=3.14159265359d0

! mesh
  integer :: Nx
  real(dp) :: length_x,dx
  real(dp),allocatable :: xn(:),xyn(:,:)

  real(dp),parameter :: gN0 = 0d0
  real(dp),parameter :: gN1 = 4.d0/5.d0
  real(dp),parameter :: gN2 = -1.d0/5.d0
  real(dp),parameter :: gN3 = 4.d0/105.d0
  real(dp),parameter :: gN4 = -1.d0/280.d0
  real(dp),parameter :: cN0 = -205.d0/72.d0
  real(dp),parameter :: cN1 = 8.d0/5.d0
  real(dp),parameter :: cN2 = -1.d0/5.d0
  real(dp),parameter :: cN3 = 8.d0/315.d0
  real(dp),parameter :: cN4 = -1.d0/560.d0

! GS: wave-function, density, potential and so on
  integer :: Ncg
  real(dp),allocatable :: wfn(:,:), rho(:), v_ext(:), v_int(:,:), v_all(:,:)
  real(dp),allocatable :: jx(:)

! TD
  character(4) :: RT_mode
  integer :: Nt_iter
  real(dp) :: T_calc,dt,kick_mom
  complex(zp),allocatable :: zwfn(:,:)
  real(dp),allocatable :: dipole_t(:),norm_t(:)
  real(dp) :: field_max,field_duration,field_omega
  real(dp) :: field_max_eV_per_AA,field_duration_fs,field_omega_eV
  real(dp),allocatable :: field_t(:)
! TD-Lanczos
  integer,parameter :: NLanczos = 6
  complex(zp),allocatable :: zwfn_Lanczos(:,:,:)

! collision
  real(dp) :: Ekin0, x0_col, delta_x_col

! single-particle problem
  real(dp),allocatable :: wfn_sp(:)

! exact exchange-correlation potential
!! TDHF type
  integer,parameter :: Nc_exc = 10
  real(dp),allocatable :: alpha_xc(:,:), v_xc_tdhf(:)
  complex(dp),allocatable :: zwfn_st(:,:)

end module global_variables


C**************************************************************************
C Set of routines taken from SYLVIE.TLB
C Used by DIANE deconvolution routines
C Contains: FOURIER1, FOURIER, D_TO_S, S_TO_D, MOD_TF
C
C JLP
C Version 20-04-91
C--************************************************************************
	subroutine fourier1(br,bi,nx,ny,option)
C
C recoit l'image sous forme de deux tableaux R*8 de N valeurs :
C br est la partie reelle de l'image et bi la partie imaginaire (eventuelle)
C En sortie, la partie reelle et la partie imaginaire de la
C T.F. sont rangees de nouveau dans br et bi.
C
C OPTION :	+ 1	T.F. directe
C		- 1	T.F. inverse
C
	integer	nx,ny,npix(2),option, nsize, idim
 	real*8	br(nx,ny), bi(nx,ny)
	integer madrid(1),data
	common /vmr/madrid
C
	idim=nx
	npix(1)=nx
	npix(2)=ny
	nsize=8*nx*ny
C Allocation of memory:
	call jlp_getvm (data,nsize)
C Transfer:
	call move8tod(madrid(data),br,bi,nx,ny,idim)
C FFT
	call fourn1(madrid(data),npix,2,option)

C Transfer:
	call movedto8(madrid(data),br,bi,nx,ny,idim)

C Freeing memory:
	call jlp_freevm (data,nsize)
	return
        end
C********************************************************
C Subroutine to prepare the data for "fourn1"
	subroutine move8tod(data,br,bi,nx,ny,idim)
	real*4 data(*)
	real*8 br(idim,*),bi(idim,*)
	integer*4 i,j,k
	k=1
	do j=1,ny
	  do i=1,nx
          data(k)=sngl(br(i,j))
          data(k+1)=sngl(bi(i,j))
	  k=k+2
	  end do
	end do
        return
	end
C********************************************************
C Subroutine to sort out the data from "fourn1"
	subroutine movedto8(data,br,bi,nx,ny,idim)
	real*4 data(*)
	real*8 br(idim,*),bi(idim,*)
	integer*4 i,j,k
	k=1
	do j=1,ny
	  do i=1,nx
          br(i,j)=dble(data(k))
          bi(i,j)=dble(data(k+1))
	  k=k+2
	  end do
	end do
        return
	end
C*******************************************************
	subroutine fourier(br,bi,nx,ny,option)
C
C recoit l'image sous forme de deux tableaux R*8 de N valeurs :
C br est la partie reelle de l'image et bi la partie imaginaire (eventuelle)
C apres l'appel de C06FJF (NAG) la partie reelle et la partie imaginaire de la
C T.F. sont rangees de nouveau dans br et bi.
C
C OPTION :	+ 1	T.F. directe
C		- 1	T.F. inverse
C
	integer	dpwork,nx,ny,ntot,npix(2),option, wsize
 	real*8	br(nx,ny), bi(nx,ny)
	real*8	d_sn
C
	integer madrid(1)
	common /vmr/madrid
C
	ifail = 0
	ntot=nx*ny
        npix(1)=nx
        npix(2)=ny
C
C on calcule la racine de N en DP
C
	d_sn = sqrt (float(ntot))
C
C Pour le calcul de la T.F. inverse
C
	if (option .eq. -1) then
C Normalization for inverse FFT
	 do j = 1, ny
	  do i = 1, nx
	   br(i,j) = br(i,j)/d_sn
	   bi(i,j) = bi(i,j)/d_sn
	  end do
	 end do
C Calling NAG routine:
CJLP92 	 call C06GCF (bi, ntot, ifail)
 	endif
C
C reservons de la place en memoire pour faciliter le calcul
C
	lwork = 3 * max(nx,ny)
        wsize = 8 * lwork
	call jlp_getvm (dpwork,wsize)
C
C calcul de la T.F. (NAG)
C (NAG divides by sqrt(ntot)...)
C
CJLP92	call C06FJF (2, npix, ntot, br, bi, madrid(dpwork), lwork, ifail)
C
C si on a calcule la T.F. inverse
C
	if (option .eq. -1) then
CJLP92	 call C06GCF (bi, ntot, ifail)
	else
C Normalization for direct FT
	 do j = 1, nx
	  do i = 1, ny
	   br(i,j) = br(i,j)*d_sn
	   bi(i,j) = bi(i,j)*d_sn
	  end do
	 end do
	end if
C
	call jlp_freevm (dpwork,wsize)
	return
	end
C**************************************************************
	subroutine s_to_d (r4,r8,n)
C Passage de simple precision (R*4) en double precision (R*8)
C
	integer	n, i
	real*4		R4(n)
	real*8		R8(n)
C
	do i = 1,n
	 R8(i) = dble(R4(i))
	end do
	return
	end
C***********************************************************
	subroutine d_to_s (r8,r4,n)
C
C Passage de double precision (R*8) en simple precision (R*4)
C
	integer	n, i
	real*4	r4(n)
	real*8	r8(n)
C
	do i = 1,n
	 r4(i) = sngl(r8(i))
	end do
C
	return
	end
C***********************************************************
	subroutine mod_tf (n, preal, pimag)
C
C calcul du module
C
	integer	n, i
	real*8		preal(n), pimag(n)
C
	do i = 1,n
	 preal(i) = dsqrt((preal(i)*preal(i))+(pimag(i)*pimag(i)))
	end do
C
	return
	end


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_HYD_COR_XY

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_HYD_COR_XY

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_HYD_COR_XY( NI , NJ , K , HYD_COR_XY )

    USE MR_MOD_OPERATOR_UV

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    INTEGER(KKID_KIND) , INTENT(IN ) :: K

    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:2) :: HYD_COR_XY

    HYD_COR_XY = + DT * COR2 *   &
    ( MW .MRUVSCL.   &
      ( MW .MRUVSCL.   &
        ( FUV .MRUVTFM.   &
          ( .MRUVROT. UV(:,:,1:2, K ) )   &
        )   &
      )   &
    )

  END SUBROUTINE MR_CALC_HYD_COR_XY

  END MODULE MR_MOD_CALC_HYD_COR_XY


     program demo_width
        use M_calcomp
        implicit none
        integer :: i,n, ii
        real    :: angle, rad, xx, yy
        call plots(0.0,10.0,0.0,10.0)
        call plot(5.0,5.0,-3)
        angle=0.0
        n=30
        do i=1,n
           ii=360/n
           call width(i*10)
           rad=0.0174533*angle
           xx=5.0*cos (rad)
           yy=5.0*sin (rad)
           call plot( 0.0, 0.0,3)
           call plot(  xx,  yy,2)
           angle=angle+360.0/n
        enddo
        call plot(0.0,0.0,999)
     end program demo_width