PyFishPack 0.1.0__cp313-cp313-win_amd64.whl

PyFishPack/src/type_PeriodicFastFourierTransform.f90

@@ -0,0 +1,3789 @@
+!
+!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!     *                                                               *
+!     *                  copyright (c) 2005 by UCAR                   *
+!     *                                                               *
+!     *       University Corporation for Atmospheric Research         *
+!     *                                                               *
+!     *                      all rights reserved                      *
+!     *                                                               *
+!     *                         Fishpack                              *
+!     *                                                               *
+!     *                      A Package of Fortran                     *
+!     *                                                               *
+!     *                Subroutines and Example Programs               *
+!     *                                                               *
+!     *               for Modeling Geophysical Processes              *
+!     *                                                               *
+!     *                             by                                *
+!     *                                                               *
+!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
+!     *                                                               *
+!     *                             of                                *
+!     *                                                               *
+!     *         the National Center for Atmospheric Research          *
+!     *                                                               *
+!     *                Boulder, Colorado  (80307)  U.S.A.             *
+!     *                                                               *
+!     *                   which is sponsored by                       *
+!     *                                                               *
+!     *              the National Science Foundation                  *
+!     *                                                               *
+!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+!
+! PURPOSE
+!
+!     This module consists of procedures which perform fast Fourier
+!     transforms for both complex and real periodic sequences and
+!     certain other symmetric sequences that are listed below.
+!
+! USAGE
+!
+!     1.   rffti     initialize  rfftf and rfftb
+!     2.   rfftf     forward transform of a real periodic sequence
+!     3.   rfftb     backward transform of a real coefficient array
+!
+!     4.   ezffti    initialize ezfftf and ezfftb
+!     5.   ezfftf    a simplified real periodic forward transform
+!     6.   ezfftb    a simplified real periodic backward transform
+!
+!     7.   sinti     initialize sint
+!     8.   sint      sine transform of a real odd sequence
+!
+!     9.   costi     initialize cost
+!     10.  cost      cosine transform of a real even sequence
+!
+!     11.  sinqi     initialize sinqf and sinqb
+!     12.  sinqf     forward sine transform with odd wave numbers
+!     13.  sinqb     unnormalized inverse of sinqf
+!
+!     14.  cosqi     initialize cosqf and cosqb
+!     15.  cosqf     forward cosine transform with odd wave numbers
+!     16.  cosqb     unnormalized inverse of cosqf
+!
+!     17.  cffti     initialize cfftf and cfftb
+!     18.  cfftf     forward transform of a complex periodic sequence
+!     19.  cfftb     unnormalized inverse of cfftf
+!
+! SPECIAL CONDITIONS
+!
+!     Before calling routines ezfftb and ezfftf for the first time,
+!     or before calling ezfftb and ezfftf with a different length,
+!     users must initialize by calling routine ezffti.
+!
+! HISTORY
+!
+!     * Developed at NCAR in boulder, colorado by paul n. swarztrauber
+!       of the scientific computing division.  Released on NCAR's public
+!       software libraries in January 1980.
+!     * Modified may 29, 1985 to increase efficiency.
+!     * Updated in 2016 to incorporate features of Fortran 2008+
+!
+!
+! **********************************************************************
+!
+!
+! **********************************************************************
+!
+!     subroutine rfftf(n, r, wsave)
+!
+!     subroutine rfftf computes the fourier coefficients of a real
+!     perodic sequence (fourier analysis). the transform is defined
+!     below at output parameter r.
+!
+!     input parameters
+!
+!     n       the length of the array r to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!             n may change so long as different work arrays are provided
+!
+!     r       a real array of length n which contains the sequence
+!             to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 2*n+15.
+!             in the program that calls rfftf. the wsave array must be
+!             initialized by calling subroutine rffti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!             the same wsave array can be used by rfftf and rfftb.
+!
+!
+!     output parameters
+!
+!     r       r(1) = the sum from i=1 to i=n of r(i)
+!
+!             if n is even set l =n/2   , if n is odd set l =(n+1)/2
+!
+!               then for k = 2, ..., l
+!
+!                  r(2*k-2) = the sum from i = 1 to i = n of
+!
+!                       r(i)*cos((k-1)*(i-1)*2*pi/n)
+!
+!                  r(2*k-1) = the sum from i = 1 to i = n of
+!
+!                      -r(i)*sin((k-1)*(i-1)*2*pi/n)
+!
+!             if n is even
+!
+!                  r(n) = the sum from i = 1 to i = n of
+!
+!                       (-1)**(i-1)*r(i)
+!
+!      *****  note
+!                  this transform is unnormalized since a call of rfftf
+!                  followed by a call of rfftb will multiply the input
+!                  sequence by n.
+!
+!     wsave   contains results which must not be destroyed between
+!             calls of rfftf or rfftb.
+!
+!
+! **********************************************************************
+!
+!     subroutine rfftb(n, r, wsave)
+!
+!     subroutine rfftb computes the real perodic sequence from its
+!     fourier coefficients (fourier synthesis). the transform is defined
+!     below at output parameter r.
+!
+!     input parameters
+!
+!     n       the length of the array r to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!             n may change so long as different work arrays are provided
+!
+!     r       a real array of length n which contains the sequence
+!             to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 2*n+15.
+!             in the program that calls rfftb. the wsave array must be
+!             initialized by calling subroutine rffti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!             the same wsave array can be used by rfftf and rfftb.
+!
+!
+!     output parameters
+!
+!     r       for n even and for i = 1, ..., n
+!
+!                  r(i) = r(1)+(-1)**(i-1)*r(n)
+!
+!                       plus the sum from k=2 to k=n/2 of
+!
+!                        TWO * r(2*k-2)*cos((k-1)*(i-1)*2*pi/n)
+!
+!                       -TWO * r(2*k-1)*sin((k-1)*(i-1)*2*pi/n)
+!
+!             for n odd and for i = 1, ..., n
+!
+!                  r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of
+!
+!                       TWO * r(2*k-2)*cos((k-1)*(i-1)*2*pi/n)
+!
+!                      -TWO * r(2*k-1)*sin((k-1)*(i-1)*2*pi/n)
+!
+!      *****  note
+!                  this transform is unnormalized since a call of rfftf
+!                  followed by a call of rfftb will multiply the input
+!                  sequence by n.
+!
+!     wsave   contains results which must not be destroyed between
+!             calls of rfftb or rfftf.
+!
+!
+! **********************************************************************
+!
+!     subroutine ezffti(n, wsave)
+!
+!     subroutine ezffti initializes the array wsave which is used in
+!     both ezfftf and ezfftb. the prime factorization of n together with
+!     a tabulation of the trigonometric functions are computed and
+!     stored in wsave.
+!
+!     input parameter
+!
+!     n       the length of the sequence to be transformed.
+!
+!     output parameter
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             the same work array can be used for both ezfftf and ezfftb
+!             as long as n remains unchanged. different wsave arrays
+!             are required for different values of n.
+!
+!
+! **********************************************************************
+!
+!     subroutine ezfftf(n, r, azero, a, b, wsave)
+!
+!     subroutine ezfftf computes the fourier coefficients of a real
+!     perodic sequence (fourier analysis). the transform is defined
+!     below at output parameters azero, a and b. ezfftf is a simplified
+!     but slower Version of rfftf.
+!
+!     input parameters
+!
+!     n       the length of the array r to be transformed.  the method
+!             is must efficient when n is the product of small primes.
+!
+!     r       a real array of length n which contains the sequence
+!             to be transformed. r is not destroyed.
+!
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             in the program that calls ezfftf. the wsave array must be
+!             initialized by calling subroutine ezffti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!             the same wsave array can be used by ezfftf and ezfftb.
+!
+!     output parameters
+!
+!     azero   the sum from i=1 to i=n of r(i)/n
+!
+!     a, b     for n even b(n/2)=0. and a(n/2) is the sum from i=1 to
+!             i=n of (-1)**(i-1)*r(i)/n
+!
+!             for n even define kmax=n/2-1
+!             for n odd  define kmax=(n-1)/2
+!
+!             then for  k=1, ..., kmax
+!
+!                  a(k) equals the sum from i=1 to i=n of
+!
+!                       2./n*r(i)*cos(k*(i-1)*2*pi/n)
+!
+!                  b(k) equals the sum from i=1 to i=n of
+!
+!                       2./n*r(i)*sin(k*(i-1)*2*pi/n)
+!
+!
+! **********************************************************************
+!
+!     subroutine ezfftb(n, r, azero, a, b, wsave)
+!
+!     subroutine ezfftb computes a real perodic sequence from its
+!     fourier coefficients (fourier synthesis). the transform is
+!     defined below at output parameter r. ezfftb is a simplified
+!     but slower Version of rfftb.
+!
+!     input parameters
+!
+!     n       the length of the output array r.  the method is most
+!             efficient when n is the product of small primes.
+!
+!     azero   the constant fourier coefficient
+!
+!     a, b     arrays which contain the remaining fourier coefficients
+!             these arrays are not destroyed.
+!
+!             the length of these arrays depends on whether n is even or
+!             odd.
+!
+!             if n is even n/2    locations are required
+!             if n is odd(n-1)/2 locations are required
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             in the program that calls ezfftb. the wsave array must be
+!             initialized by calling subroutine ezffti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!             the same wsave array can be used by ezfftf and ezfftb.
+!
+!
+!     output parameters
+!
+!     r       if n is even define kmax=n/2
+!             if n is odd  define kmax=(n-1)/2
+!
+!             then for i=1, ..., n
+!
+!                  r(i)=azero plus the sum from k=1 to k=kmax of
+!
+!                  a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n)
+!
+!     ********************* complex notation **************************
+!
+!             for j=1, ..., n
+!
+!             r(j) equals the sum from k=-kmax to k=kmax of
+!
+!                  c(k)*exp(i*k*(j-1)*2*pi/n)
+!
+!             where
+!
+!                  c(k) = .5*cmplx(a(k), -b(k))   for k=1, ..., kmax
+!
+!                  c(-k) = conjg(c(k))
+!
+!                  c(0) = azero
+!
+!                       and i=sqrt(-1)
+!
+!     *************** amplitude - phase notation ***********************
+!
+!             for i=1, ..., n
+!
+!             r(i) equals azero plus the sum from k=1 to k=kmax of
+!
+!                  alpha(k)*cos(k*(i-1)*2*pi/n+beta(k))
+!
+!             where
+!
+!                  alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k))
+!
+!                  cos(beta(k))=a(k)/alpha(k)
+!
+!                  sin(beta(k))=-b(k)/alpha(k)
+!
+! **********************************************************************
+!
+!     subroutine sinti(n, wsave)
+!
+!     subroutine sinti initializes the array wsave which is used in
+!     subroutine sint. the prime factorization of n together with
+!     a tabulation of the trigonometric functions are computed and
+!     stored in wsave.
+!
+!     input parameter
+!
+!     n       the length of the sequence to be transformed.  the method
+!             is most efficient when n+1 is a product of small primes.
+!
+!     output parameter
+!
+!     wsave   a work array with at least int(2.5*n+15) locations.
+!             different wsave arrays are required for different values
+!             of n. the contents of wsave must not be changed between
+!             calls of sint.
+!
+! **********************************************************************
+!
+!     subroutine sint(n, x, wsave)
+!
+!     subroutine sint computes the discrete fourier sine transform
+!     of an odd sequence x(i). the transform is defined below at
+!     output parameter x.
+!
+!     sint is the unnormalized inverse of itself since a call of sint
+!     followed by another call of sint will multiply the input sequence
+!     x by 2*(n+1).
+!
+!     the array wsave which is used by subroutine sint must be
+!     initialized by calling subroutine sinti(n, wsave).
+!
+!     input parameters
+!
+!     n       the length of the sequence to be transformed.  the method
+!             is most efficient when n+1 is the product of small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!
+!     wsave   a work array with dimension at least int(2.5*n+15)
+!             in the program that calls sint. the wsave array must be
+!             initialized by calling subroutine sinti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                  x(i)= the sum from k=1 to k=n
+!
+!                       2*x(k)*sin(k*i*pi/(n+1))
+!
+!                  a call of sint followed by another call of
+!                  sint will multiply the sequence x by 2*(n+1).
+!                  hence sint is the unnormalized inverse
+!                  of itself.
+!
+!     wsave   contains initialization calculations which must not be
+!             destroyed between calls of sint.
+!
+! **********************************************************************
+!
+!     subroutine costi(n, wsave)
+!
+!     subroutine costi initializes the array wsave which is used in
+!     subroutine cost. the prime factorization of n together with
+!     a tabulation of the trigonometric functions are computed and
+!     stored in wsave.
+!
+!     input parameter
+!
+!     n       the length of the sequence to be transformed.  the method
+!             is most efficient when n-1 is a product of small primes.
+!
+!     output parameter
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             different wsave arrays are required for different values
+!             of n. the contents of wsave must not be changed between
+!             calls of cost.
+!
+! **********************************************************************
+!
+!     subroutine cost(n, x, wsave)
+!
+!     subroutine cost computes the discrete fourier cosine transform
+!     of an even sequence x(i). the transform is defined below at output
+!     parameter x.
+!
+!     cost is the unnormalized inverse of itself since a call of cost
+!     followed by another call of cost will multiply the input sequence
+!     x by 2*(n-1). the transform is defined below at output parameter x
+!
+!     the array wsave which is used by subroutine cost must be
+!     initialized by calling subroutine costi(n, wsave).
+!
+!     input parameters
+!
+!     n       the length of the sequence x. n must be greater than 1.
+!             the method is most efficient when n-1 is a product of
+!             small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15
+!             in the program that calls cost. the wsave array must be
+!             initialized by calling subroutine costi(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                 x(i) = x(1)+(-1)**(i-1)*x(n)
+!
+!                  + the sum from k=2 to k=n-1
+!
+!                      2*x(k)*cos((k-1)*(i-1)*pi/(n-1))
+!
+!                  a call of cost followed by another call of
+!                  cost will multiply the sequence x by 2*(n-1)
+!                  hence cost is the unnormalized inverse
+!                  of itself.
+!
+!     wsave   contains initialization calculations which must not be
+!             destroyed between calls of cost.
+!
+! **********************************************************************
+!
+!     subroutine sinqi(n, wsave)
+!
+!     subroutine sinqi initializes the array wsave which is used in
+!     both sinqf and sinqb. the prime factorization of n together with
+!     a tabulation of the trigonometric functions are computed and
+!     stored in wsave.
+!
+!     input parameter
+!
+!     n       the length of the sequence to be transformed. the method
+!             is most efficient when n is a product of small primes.
+!
+!     output parameter
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             the same work array can be used for both sinqf and sinqb
+!             as long as n remains unchanged. different wsave arrays
+!             are required for different values of n. the contents of
+!             wsave must not be changed between calls of sinqf or sinqb.
+!
+! **********************************************************************
+!
+!     subroutine sinqf(n, x, wsave)
+!
+!     subroutine sinqf computes the fast fourier transform of quarter
+!     wave data. that is , sinqf computes the coefficients in a sine
+!     series representation with only odd wave numbers. the transform
+!     is defined below at output parameter x.
+!
+!     sinqb is the unnormalized inverse of sinqf since a call of sinqf
+!     followed by a call of sinqb will multiply the input sequence x
+!     by 4*n.
+!
+!     the array wsave which is used by subroutine sinqf must be
+!     initialized by calling subroutine sinqi(n, wsave).
+!
+!
+!     input parameters
+!
+!     n       the length of the array x to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             in the program that calls sinqf. the wsave array must be
+!             initialized by calling subroutine sinqi(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                  x(i) = (-1)**(i-1)*x(n)
+!
+!                     + the sum from k=1 to k=n-1 of
+!
+!                     2*x(k)*sin((2*i-1)*k*pi/(2*n))
+!
+!                  a call of sinqf followed by a call of
+!                  sinqb will multiply the sequence x by 4*n.
+!                  therefore sinqb is the unnormalized inverse
+!                  of sinqf.
+!
+!     wsave   contains initialization calculations which must not
+!             be destroyed between calls of sinqf or sinqb.
+!
+! **********************************************************************
+!
+!     subroutine sinqb(n, x, wsave)
+!
+!     subroutine sinqb computes the fast fourier transform of quarter
+!     wave data. that is , sinqb computes a sequence from its
+!     representation in terms of a sine series with odd wave numbers.
+!     the transform is defined below at output parameter x.
+!
+!     sinqf is the unnormalized inverse of sinqb since a call of sinqb
+!     followed by a call of sinqf will multiply the input sequence x
+!     by 4*n.
+!
+!     the array wsave which is used by subroutine sinqb must be
+!     initialized by calling subroutine sinqi(n, wsave).
+!
+!
+!     input parameters
+!
+!     n       the length of the array x to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             in the program that calls sinqb. the wsave array must be
+!             initialized by calling subroutine sinqi(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                  x(i)= the sum from k=1 to k=n of
+!
+!                    4*x(k)*sin((2k-1)*i*pi/(2*n))
+!
+!                  a call of sinqb followed by a call of
+!                  sinqf will multiply the sequence x by 4*n.
+!                  therefore sinqf is the unnormalized inverse
+!                  of sinqb.
+!
+!     wsave   contains initialization calculations which must not
+!             be destroyed between calls of sinqb or sinqf.
+!
+! **********************************************************************
+!
+!     subroutine cosqi(n, wsave)
+!
+!     subroutine cosqi initializes the array wsave which is used in
+!     both cosqf and cosqb. the prime factorization of n together with
+!     a tabulation of the trigonometric functions are computed and
+!     stored in wsave.
+!
+!     input parameter
+!
+!     n       the length of the array to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!
+!     output parameter
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15.
+!             the same work array can be used for both cosqf and cosqb
+!             as long as n remains unchanged. different wsave arrays
+!             are required for different values of n. the contents of
+!             wsave must not be changed between calls of cosqf or cosqb.
+!
+! **********************************************************************
+!
+!     subroutine cosqf(n, x, wsave)
+!
+!     subroutine cosqf computes the fast fourier transform of quarter
+!     wave data. that is , cosqf computes the coefficients in a cosine
+!     series representation with only odd wave numbers. the transform
+!     is defined below at output parameter x
+!
+!     cosqf is the unnormalized inverse of cosqb since a call of cosqf
+!     followed by a call of cosqb will multiply the input sequence x
+!     by 4*n.
+!
+!     the array wsave which is used by subroutine cosqf must be
+!     initialized by calling subroutine cosqi(n, wsave).
+!
+!
+!     input parameters
+!
+!     n       the length of the array x to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!     wsave   a work array which must be dimensioned at least 3*n+15
+!             in the program that calls cosqf. the wsave array must be
+!             initialized by calling subroutine cosqi(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                  x(i) = x(1) plus the sum from k=2 to k=n of
+!
+!                     2*x(k)*cos((2*i-1)*(k-1)*pi/(2*n))
+!
+!                  a call of cosqf followed by a call of
+!                  cosqb will multiply the sequence x by 4*n.
+!                  therefore cosqb is the unnormalized inverse
+!                  of cosqf.
+!
+!     wsave   contains initialization calculations which must not
+!             be destroyed between calls of cosqf or cosqb.
+!
+! **********************************************************************
+!
+!     subroutine cosqb(n, x, wsave)
+!
+!     subroutine cosqb computes the fast fourier transform of quarter
+!     wave data. that is , cosqb computes a sequence from its
+!     representation in terms of a cosine series with odd wave numbers.
+!     the transform is defined below at output parameter x.
+!
+!     cosqb is the unnormalized inverse of cosqf since a call of cosqb
+!     followed by a call of cosqf will multiply the input sequence x
+!     by 4*n.
+!
+!     the array wsave which is used by subroutine cosqb must be
+!     initialized by calling subroutine cosqi(n, wsave).
+!
+!
+!     input parameters
+!
+!     n       the length of the array x to be transformed.  the method
+!             is most efficient when n is a product of small primes.
+!
+!     x       an array which contains the sequence to be transformed
+!
+!     wsave   a work array that must be dimensioned at least 3*n+15
+!             in the program that calls cosqb. the wsave array must be
+!             initialized by calling subroutine cosqi(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!
+!     output parameters
+!
+!     x       for i=1, ..., n
+!
+!                  x(i)= the sum from k=1 to k=n of
+!
+!                    4*x(k)*cos((2*k-1)*(i-1)*pi/(2*n))
+!
+!                  a call of cosqb followed by a call of
+!                  cosqf will multiply the sequence x by 4*n.
+!                  therefore cosqf is the unnormalized inverse
+!                  of cosqb.
+!
+!     wsave   contains initialization calculations which must not
+!             be destroyed between calls of cosqb or cosqf.
+!
+! **********************************************************************
+!
+!
+! **********************************************************************
+!
+!     subroutine cfftf(n, c, wsave)
+!
+!     subroutine cfftf computes the forward complex discrete fourier
+!     transform (the fourier analysis). equivalently , cfftf computes
+!     the fourier coefficients of a complex periodic sequence.
+!     the transform is defined below at output parameter c.
+!
+!     the transform is not normalized. to obtain a normalized transform
+!     the output must be divided by n. otherwise a call of cfftf
+!     followed by a call of cfftb will multiply the sequence by n.
+!
+!     the array wsave which is used by subroutine cfftf must be
+!     initialized by calling subroutine cffti(n, wsave).
+!
+!     input parameters
+!
+!
+!     n      the length of the complex sequence c. the method is
+!            more efficient when n is the product of small primes. n
+!
+!     c      a complex array of length n which contains the sequence
+!
+!     wsave   a real work array which must be dimensioned at least 4n+15
+!             in the program that calls cfftf. the wsave array must be
+!             initialized by calling subroutine cffti(n, wsave) and a
+!             different wsave array must be used for each different
+!             value of n. this initialization does not have to be
+!             repeated so long as n remains unchanged thus subsequent
+!             transforms can be obtained faster than the first.
+!             the same wsave array can be used by cfftf and cfftb.
+!
+!     output parameters
+!
+!     c      for j=1, ..., n
+!
+!                c(j)=the sum from k=1, ..., n of
+!
+!                      c(k)*exp(-i*(j-1)*(k-1)*2*pi/n)
+!
+!                            where i=sqrt(-1)
+!
+!     wsave   contains initialization calculations which must not be
+!             destroyed between calls of subroutine cfftf or cfftb
+!
+! **********************************************************************
+
+module type_PeriodicFastFourierTransform
+
+    use fishpack_precision, only: &
+        wp, & ! Working precision
+        ip, & ! Integer precision
+        PI, &
+        TWO_PI, &
+        HALF_PI
+
+    ! Explicit typing only
+    implicit None
+
+    ! Everything is private unless stated otherwise
+    private
+    public :: PeriodicFastFourierTransform
+    public :: rffti ! initialize  rfftf and rfftb
+    public :: rfftf ! forward transform of a real periodic sequence
+    public :: rfftb ! backward transform of a real coefficient array
+    public :: ezffti !initialize ezfftf and ezfftb
+    public :: ezfftf ! a simplified real periodic forward transform
+    public :: ezfftb ! a simplified real periodic backward transform
+    public :: sinti ! initialize sint
+    public :: sint ! sine transform of a real odd sequence
+    public :: costi ! initialize cost
+    public :: cost ! cosine transform of a real even sequence
+    public :: sinqi ! initialize sinqf and sinqb
+    public :: sinqf ! forward sine transform with odd wave numbers
+    public :: sinqb ! unnormalized inverse of sinqf
+    public :: cosqi ! initialize cosqf and cosqb
+    public :: cosqf ! forward cosine transform with odd wave numbers
+    public :: cosqb ! unnormalized inverse of cosqf
+    public :: cffti ! initialize cfftf and cfftb
+    public :: cfftf ! forward transform of a complex periodic sequence
+    public :: cfftb ! unnormalized inverse of cfftf
+
+    ! Parameters confined to the module
+    real(wp), parameter :: ZERO = 0.0_wp
+    real(wp), parameter :: HALF = 0.5_wp
+    real(wp), parameter :: ONE = 1.0_wp
+    real(wp), parameter :: TWO = 2.0_wp
+    real(wp), parameter :: THREE = 3.0_wp
+    real(wp), parameter :: FOUR = 4.0_wp
+    real(wp), parameter :: FIVE = 5.0_wp
+    real(wp), parameter :: SQRT_2 = sqrt(TWO)
+    real(wp), parameter :: SQRT_3 = sqrt(THREE)
+    real(wp), parameter :: SQRT_5 = sqrt(FIVE)
+
+    type, public :: PeriodicFastFourierTransform
+    contains
+        ! Type-bound procedures
+        procedure, nopass, public :: rffti
+        procedure, nopass, public :: rfftf
+        procedure, nopass, public :: rfftb
+        procedure, nopass, public :: ezffti
+        procedure, nopass, public :: ezfftf
+        procedure, nopass, public :: ezfftb
+        procedure, nopass, public :: sinti
+        procedure, nopass, public :: sint
+        procedure, nopass, public :: costi
+        procedure, nopass, public :: cost
+        procedure, nopass, public :: sinqi
+        procedure, nopass, public :: sinqf
+        procedure, nopass, public :: sinqb
+        procedure, nopass, public :: cosqi
+        procedure, nopass, public :: cosqf
+        procedure, nopass, public :: cosqb
+        procedure, nopass, public :: cffti
+        procedure, nopass, public :: cfftf
+        procedure, nopass, public :: cfftb
+    end type PeriodicFastFourierTransform
+
+contains
+
+    subroutine ezfftf(n, r, azero, a, b, wsave)
+
+        ! Dummy arguments
+        integer(ip), intent(in)  :: n
+        real(wp),    intent(out) :: azero
+        real(wp),    intent(in)  :: r(*)
+        real(wp),    intent(out) :: a(*)
+        real(wp),    intent(out) :: b(*)
+        real(wp)                  :: wsave(*)
+
+        ! Local variables
+        integer(ip) :: ns2, ns2m
+        real(wp)    :: cf, cfm
+
+        !
+        if (3 > n) then
+            if (n /= 2) then
+                azero = r(1)
+                return
+            end if
+            azero = HALF*(r(1)+r(2))
+            a(1) = HALF*(r(1)-r(2))
+            return
+        end if
+
+        wsave(:n) = r(:n)
+
+        call rfftf(n, wsave, wsave(n+1))
+
+        cf = TWO/n
+        cfm = -cf
+        azero = HALF*cf*wsave(1)
+        ns2 =(n + 1)/2
+        ns2m = ns2 - 1
+        a(:ns2m) = cf*wsave(2:ns2m*2:2)
+        b(:ns2m) = cfm*wsave(3:ns2m*2+1:2)
+
+        if (mod(n, 2) /= 1) then
+            a(ns2) = HALF*cf*wsave(n)
+            b(ns2) = ZERO
+        end if
+
+    end subroutine ezfftf
+
+    subroutine ezfftb(n, r, azero, a, b, wsave)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: n
+        real(wp), intent(in)    :: azero
+        real(wp)                 :: r(*)
+        real(wp), intent(in)    :: a(*)
+        real(wp), intent(in)    :: b(*)
+        real(wp)                 :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: ns2
+
+
+        if (3 > n) then
+            if (n /= 2) then
+                r(1) = azero
+                return
+            end if
+            r(1) = azero + a(1)
+            r(2) = azero - a(1)
+            return
+        end if
+
+        ns2 =(n - 1)/2
+        r(2:ns2*2:2) = HALF*a(:ns2)
+        r(3:ns2*2+1:2) = -HALF*b(:ns2)
+        r(1) = azero
+
+        if (mod(n, 2) == 0) r(n) = a(ns2+1)
+
+        call rfftb(n, r, wsave(n+1))
+
+    end subroutine ezfftb
+
+    subroutine ezffti(n, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: wsave(*)
+
+
+        if (n /= 1) call real_periodic_initialization_lower_routine(n, wsave(2*n+1), wsave(3*n+1))
+
+    end subroutine ezffti
+
+    subroutine real_periodic_initialization_lower_routine(n, wa, ifac)
+
+        ! Dummy arguments
+
+        integer(ip),  intent(in)     :: n
+        real(wp),     intent(inout)  :: ifac(*)
+        real(wp),     intent(inout)  :: wa(*)
+
+        ! Local variables
+
+        integer(ip), parameter :: NTRYH(*) = [4, 2, 3, 5]
+        integer(ip) :: nl, nf, j, ntry, nq, nr, i, is, nfm1
+        integer(ip) :: l1, k1, iip, l2, ido, iipm, ii
+        real(wp) :: argh, arg1, ch1, sh1, dch1, dsh1, temp
+
+
+        ! Initialize
+        ntry = 0
+        nl = n
+        nf = 0
+        j = 0
+
+        factorization_loop: do
+
+            j = j + 1
+
+            if (j <= 4) then
+                ntry = NTRYH(j)
+            else
+                ntry = ntry + 2
+            end if
+
+            inner_loop: do
+
+                nq = nl/ntry
+                nr = nl - ntry*nq
+
+                if (nr /= 0) cycle factorization_loop
+
+                nf = nf + 1
+                ifac(nf+2) = ntry
+                nl = nq
+
+                if (ntry == 2) then
+                    if (nf /= 1) then
+                        ifac(nf+2:4:(-1)) = ifac(nf+1:3:(-1))
+                        ifac(3) = 2
+                    end if
+                end if
+
+                if (nl /= 1) cycle inner_loop
+
+                exit inner_loop
+            end do inner_loop
+            exit factorization_loop
+        end do factorization_loop
+
+        ifac(1) = n
+        ifac(2) = nf
+        argh = TWO_PI/n
+        is = 0
+        nfm1 = nf - 1
+        l1 = 1
+
+        if (nfm1 /= 0) then
+            do k1 = 1, nfm1
+                iip = int(ifac(k1+2), kind=ip)
+                l2 = l1*iip
+                ido = n/l2
+                iipm = iip - 1
+                arg1 = real(l1, kind=wp)*argh
+                ch1 = ONE
+                sh1 = ZERO
+                dch1 = cos(arg1)
+                dsh1 = sin(arg1)
+                do j = 1, iipm
+                    temp = dch1*ch1 - dsh1*sh1
+                    sh1 = dch1*sh1 + dsh1*ch1
+                    ch1 = temp
+                    i = is + 2
+                    wa(i-1) = ch1
+                    wa(i) = sh1
+                    if (ido >= 5) then
+                        do ii = 5, ido, 2
+                            i = i + 2
+                            wa(i-1) = ch1*wa(i-3) - sh1*wa(i-2)
+                            wa(i) = ch1*wa(i-2) + sh1*wa(i-3)
+                        end do
+                    end if
+                    is = is + ido
+                end do
+                l1 = l2
+            end do
+        end if
+
+    end subroutine real_periodic_initialization_lower_routine
+
+    subroutine costi(n, wsave)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: n
+        real(wp)                 :: wsave(*)
+
+        ! Local variables
+
+        integer(ip)  :: nm1, np1, ns2, k, kc
+        real(wp)     :: dt, fk
+
+
+        if (n > 3) then
+            nm1 = n - 1
+            np1 = n + 1
+            ns2 = n/2
+            dt = pi/nm1
+            fk = ZERO
+
+            do k = 2, ns2
+                kc = np1 - k
+                fk = fk + ONE
+                wsave(k) = TWO * sin(fk*dt)
+                wsave(kc) = TWO * cos(fk*dt)
+            end do
+
+            call rffti(nm1, wsave(n+1))
+
+        end if
+
+    end subroutine costi
+
+    subroutine cost(n, x, wsave)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: n
+        real(wp) :: x(*)
+        real(wp) :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: nm1, np1, ns2, k, kc, modn, i
+        real(wp) :: x1h, x1p3, tx2, c1, t1, t2, xim2, xi
+
+        !
+        nm1 = n - 1
+        np1 = n + 1
+        ns2 = n/2
+
+        if (3 < n) then
+            if (3 > n) then
+                x1h = x(1) + x(2)
+                x(2) = x(1) - x(2)
+                x(1) = x1h
+                return
+            end if
+            if (n <= 3) then
+                x1p3 = x(1) + x(3)
+                tx2 = x(2) + x(2)
+                x(2) = x(1) - x(3)
+                x(1) = x1p3 + tx2
+                x(3) = x1p3 - tx2
+                return
+            end if
+            c1 = x(1) - x(n)
+            x(1) = x(1) + x(n)
+            do k = 2, ns2
+                kc = np1 - k
+                t1 = x(k) + x(kc)
+                t2 = x(k) - x(kc)
+                c1 = c1 + wsave(kc)*t2
+                t2 = wsave(k)*t2
+                x(k) = t1 - t2
+                x(kc) = t1 + t2
+            end do
+
+            modn = mod(n, 2)
+
+            if (modn /= 0) x(ns2+1) = x(ns2+1) + x(ns2+1)
+
+            call rfftf(nm1, x, wsave(n+1))
+
+            xim2 = x(2)
+            x(2) = c1
+
+            do i = 4, n, 2
+                xi = x(i)
+                x(i) = x(i-2) - x(i-1)
+                x(i-1) = xim2
+                xim2 = xi
+            end do
+
+            if (modn /= 0) x(n) = xim2
+
+        end if
+
+    end subroutine cost
+
+    subroutine sinti(n, wsave)
+
+        ! Dummy arguments
+        integer(ip), intent(in) :: n
+        real(wp)                 :: wsave(*)
+
+        ! Local variables
+        integer(ip) :: ns2, np1, k
+        real(wp)    :: dt
+
+        if (n > 1) then
+            ns2 = n/2
+            np1 = n + 1
+            dt = PI/np1
+
+            do k = 1, ns2
+                wsave(k) = TWO * sin(k*dt)
+            end do
+
+            call rffti(np1, wsave(ns2+1))
+        end if
+
+    end subroutine sinti
+
+    subroutine sint(n, x, wsave)
+
+        ! Dummy arguments
+        integer(ip) :: n
+        real(wp) :: x(*)
+        real(wp) :: wsave(*)
+
+        ! Local variables
+        integer(ip) :: np1, iw1, iw2, iw3
+
+
+        np1 = n + 1
+        iw1 = n/2 + 1
+        iw2 = iw1 + np1
+        iw3 = iw2 + np1
+
+        call sint1(n, x, wsave, wsave(iw1), wsave(iw2), wsave(iw3))
+
+    end subroutine sint
+
+    subroutine sint1(n, war, was, xh, x, ifac)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in)  :: n
+        real(wp)              :: ifac(*)
+        real(wp)              :: war(*)
+        real(wp), intent(in) :: was(*)
+        real(wp)              :: xh(*)
+        real(wp)              :: x(*)
+
+        ! Local variables
+
+        integer(ip)         :: i, np1, ns2, k, kc, modn
+        real(wp)            :: temp, t1, t2
+
+
+        xh(:n) = war(:n)
+        war(:n) = x(:n)
+
+        if (3 > n) then
+            if (n /= 2) then
+                xh(1) = xh(1) + xh(1)
+                x(:n) = war(:n)
+                war(:n) = xh(:n)
+                return
+            end if
+            temp = SQRT_3*(xh(1)+xh(2))
+            xh(2) = SQRT_3*(xh(1)-xh(2))
+            xh(1) = temp
+            x(:n) = war(:n)
+            war(:n) = xh(:n)
+            return
+        end if
+
+        np1 = n + 1
+        ns2 = n/2
+        x(1) = ZERO
+
+        do k = 1, ns2
+            kc = np1 - k
+            t1 = xh(k) - xh(kc)
+            t2 = was(k)*(xh(k)+xh(kc))
+            x(k+1) = t1 + t2
+            x(kc+1) = t2 - t1
+        end do
+
+        modn = mod(n, 2)
+
+        if (modn /= 0) x(ns2+2) = FOUR * xh(ns2+1)
+
+        call real_forward_lower_routine(np1, x, xh, war, ifac)
+
+        xh(1) = HALF*x(1)
+
+        do i = 3, n, 2
+            xh(i-1) = -x(i)
+            xh(i) = xh(i-2) + x(i-1)
+        end do
+
+        if (modn == 0) xh(n) = -x(n+1)
+
+        x(:n) = war(:n)
+        war(:n) = xh(:n)
+
+    end subroutine sint1
+
+    subroutine cosqi(n, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: k ! Counter
+        real(wp)    :: fk, dt
+
+
+        dt = HALF_PI/n
+
+        fk = ZERO
+        do k = 1, n
+            fk = fk + ONE
+            wsave(k) = cos(fk*dt)
+        end do
+
+        call rffti(n, wsave(n+1))
+
+    end subroutine cosqi
+
+    subroutine cosqf(n, x, wsave)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: n
+        real(wp)                 :: x(*)
+        real(wp)                 :: wsave(*)
+
+        ! Local variables
+
+        real(wp) :: temp
+
+
+        if (3 < n) then
+            if (n > 2) call cosqf1(n, x, wsave, wsave(n+1))
+            temp = SQRT_2*x(2)
+            x(2) = x(1) - temp
+            x(1) = x(1) + temp
+        end if
+
+    end subroutine cosqf
+
+    subroutine cosqf1(n, x, w, xh)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: n
+        real(wp)                 :: x(*)
+        real(wp),    intent(in) :: w(*)
+        real(wp)                 :: xh(*)
+
+        ! Local variables
+
+        integer(ip) :: ns2, np2, k, kc, modn, i
+        real(wp)    :: temp
+
+
+        ns2 =(n + 1)/2
+        np2 = n + 2
+
+        do k = 2, ns2
+            kc = np2 - k
+            xh(k) = x(k) + x(kc)
+            xh(kc) = x(k) - x(kc)
+        end do
+
+        modn = mod(n, 2)
+
+        if (modn == 0) xh(ns2+1) = x(ns2+1) + x(ns2+1)
+
+        do k = 2, ns2
+            kc = np2 - k
+            x(k) = w(k-1)*xh(kc) + w(kc-1)*xh(k)
+            x(kc) = w(k-1)*xh(k) - w(kc-1)*xh(kc)
+        end do
+
+        if (modn == 0) x(ns2+1) = w(ns2)*xh(ns2+1)
+
+        call rfftf(n, x, xh)
+
+        do i = 3, n, 2
+            temp = x(i-1) - x(i)
+            x(i) = x(i-1) + x(i)
+            x(i-1) = temp
+        end do
+
+    end subroutine cosqf1
+
+    subroutine cosqb(n, x, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: x(*)
+        real(wp) :: wsave(*)
+
+        ! Local variables
+
+        real(wp), parameter :: TWO_SQRT_2 = TWO * sqrt(TWO) ! 2.82842712474619
+        real(wp)            :: temp
+
+        if (3 > n) then
+            if (n /= 2) then
+                x(1) = FOUR * x(1)
+            else
+                temp = FOUR * (x(1)+x(2))
+                x(2) = TWO_SQRT_2*(x(1)-x(2))
+                x(1) = temp
+            end if
+        end if
+
+        call cosqb1(n, x, wsave, wsave(n+1))
+
+    end subroutine cosqb
+
+    subroutine cosqb1(n, x, w, xh)
+
+        ! Dummy arguments
+
+        integer(ip)               :: n
+        real(wp)              :: x(*)
+        real(wp), intent(in) :: w(*)
+        real(wp)              :: xh(*)
+
+        ! Local variables
+
+        integer(ip) :: ns2, np2, i, modn, k, kc
+        real(wp)    :: xim1
+
+
+        ns2 =(n + 1)/2
+        np2 = n + 2
+
+        do i = 3, n, 2
+            xim1 = x(i-1) + x(i)
+            x(i) = x(i) - x(i-1)
+            x(i-1) = xim1
+        end do
+
+        x(1) = TWO*x(1)
+
+        modn = mod(n, 2)
+
+        if (modn == 0) x(n) = x(n) + x(n)
+
+        call rfftb(n, x, xh)
+
+        do k = 2, ns2
+            kc = np2 - k
+            xh(k) = w(k-1)*x(kc) + w(kc-1)*x(k)
+            xh(kc) = w(k-1)*x(k) - w(kc-1)*x(kc)
+        end do
+
+        if (modn == 0) x(ns2+1) = w(ns2)*(x(ns2+1)+x(ns2+1))
+
+        do k = 2, ns2
+            kc = np2 - k
+            x(k) = xh(k) + xh(kc)
+            x(kc) = xh(k) - xh(kc)
+        end do
+
+        x(1) = TWO*x(1)
+
+    end subroutine cosqb1
+
+    subroutine sinqi(n, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: wsave(*)
+
+
+        call cosqi(n, wsave)
+
+    end subroutine sinqi
+
+    subroutine sinqf(n, x, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: x(*)
+        real(wp) :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: ns2, k, kc
+        real(wp) :: xhold
+
+
+        if (n /= 1) then
+
+            ns2 = n/2
+
+            do k = 1, ns2
+                kc = n - k
+                xhold = x(k)
+                x(k) = x(kc+1)
+                x(kc+1) = xhold
+            end do
+
+            call cosqf(n, x, wsave)
+
+            x(2:n:2) = -x(2:n:2)
+
+        end if
+
+    end subroutine sinqf
+
+    subroutine sinqb(n, x, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: x(*)
+        real(wp) :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: ns2, k, kc
+        real(wp) :: xhold
+
+
+        if (n <= 1) then
+            x(1) = FOUR * x(1)
+        else
+            ns2 = n/2
+            x(2:n:2) = -x(2:n:2)
+
+            call cosqb(n, x, wsave)
+
+            do k = 1, ns2
+                kc = n - k
+                xhold = x(k)
+                x(k) = x(kc+1)
+                x(kc+1) = xhold
+            end do
+        end if
+
+    end subroutine sinqb
+
+    ! Purpose:
+    !
+    ! Initializes the array wsave which is used in
+    ! both cfftf and cfftb. the prime factorization of n together with
+    ! a tabulation of the trigonometric functions are computed and
+    ! stored in wsave.
+    !
+    ! input parameter
+    !
+    !     n       the length of the sequence to be transformed
+    !
+    ! output parameter
+    !
+    !     wsave   a work array which must be dimensioned at least 4*n+15
+    !             the same work array can be used for both cfftf and cfftb
+    !             as long as n remains unchanged. different wsave arrays
+    !             are required for different values of n. the contents of
+    !             wsave must not be changed between calls of cfftf or cfftb.
+    !
+    pure subroutine cffti(n, wsave)
+
+        ! Dummy arguments
+        integer(ip), intent(in)  :: n
+        real(wp),    intent(out) :: wsave(*)
+
+        ! Local variables
+        integer(ip) :: iw1, iw2
+
+        if (n /= 1) then
+            iw1 = 2*n + 1
+            iw2 = iw1 + 2*n
+            call complex_initialization_lower_routine(n, wsave(iw1), wsave(iw2))
+        end if
+
+    end subroutine cffti
+
+    pure subroutine complex_initialization_lower_routine(n, wa, ifac)
+
+        ! Dummy arguments
+        integer(ip), intent(in)   :: n
+        real(wp),    intent(out)  :: ifac(*)
+        real(wp),    intent(out)  :: wa(*)
+
+        ! Local variables
+        integer(ip), parameter :: NTRYH(*) = [3, 4, 2, 5]
+        integer(ip)            :: ntest, nf, j, ntry, nq, nr
+        integer(ip)            :: i, l1, k1, iip, ld, l2, ido
+        integer(ip)            :: idot, iipm, i1, ii
+        real(wp)               :: argh, fi, argld, arg
+
+        ! Initialize
+        nf = 0
+        ntest = n
+        ntry = 0
+        j = 0
+
+        factorization_loop: do
+
+            j = j + 1
+
+            if (j <= 4) then
+                ntry = NTRYH(j)
+            else
+                ntry = ntry + 2
+            end if
+
+            inner_loop: do
+
+                nq = ntest/ntry
+                nr = ntest - ntry*nq
+
+                if (nr /= 0) cycle factorization_loop
+
+                nf = nf + 1
+                ifac(nf+2) = ntry
+                ntest = nq
+
+                if (ntry == 2) then
+                    if (nf /= 1) then
+                        ifac(nf+2:4:(-1)) = ifac(nf+1:3:(-1))
+                        ifac(3) = 2
+                    end if
+                end if
+
+                if (ntest /= 1) cycle inner_loop
+                exit inner_loop
+            end do inner_loop
+            exit factorization_loop
+        end do factorization_loop
+
+        ifac(1) = n
+        ifac(2) = nf
+        argh = TWO_PI/n
+        i = 2
+        l1 = 1
+        do k1 = 1, nf
+            iip = int(ifac(k1+2), kind=ip)
+            ld = 0
+            l2 = l1*iip
+            ido = n/l2
+            idot = ido + ido + 2
+            iipm = iip - 1
+            set_workspace_loop: do j = 1, iipm
+                i1 = i
+                wa(i-1) = ONE
+                wa(i) = ZERO
+                ld = ld + l1
+                fi = ZERO
+                argld = real(ld, kind=wp)*argh
+                do ii = 4, idot, 2
+                    i = i + 2
+                    fi = fi + ONE
+                    arg = fi*argld
+                    wa(i-1) = cos(arg)
+                    wa(i) = sin(arg)
+                end do
+
+                if (iip <= 5) cycle set_workspace_loop
+
+                wa(i1-1) = wa(i-1)
+                wa(i1) = wa(i)
+
+            end do set_workspace_loop
+            l1 = l2
+        end do
+
+    end subroutine complex_initialization_lower_routine
+
+    ! Purpose:
+    !
+    !     Computes the backward complex discrete fourier
+    !     transform (the fourier synthesis). equivalently , cfftb computes
+    !     a complex periodic sequence from its fourier coefficients.
+    !     the transform is defined below at output parameter c.
+    !
+    !     a call of cfftf followed by a call of cfftb will multiply the
+    !     sequence by n.
+    !
+    !     the array wsave which is used by subroutine cfftb must be
+    !     initialized by calling subroutine cffti(n, wsave).
+    !
+    !     input parameters
+    !
+    !
+    !     n      the length of the complex sequence c. the method is
+    !            more efficient when n is the product of small primes.
+    !
+    !     c      a complex array of length n which contains the sequence
+    !
+    !     wsave   a real work array which must be dimensioned at least 4n+15
+    !             in the program that calls cfftb. the wsave array must be
+    !             initialized by calling subroutine cffti(n, wsave) and a
+    !             different wsave array must be used for each different
+    !             value of n. this initialization does not have to be
+    !             repeated so long as n remains unchanged thus subsequent
+    !             transforms can be obtained faster than the first.
+    !             the same wsave array can be used by cfftf and cfftb.
+    !
+    !     output parameters
+    !
+    !     c      for j=1, ..., n
+    !
+    !                c(j)=the sum from k=1, ..., n of
+    !
+    !                      c(k)*exp(i*(j-1)*(k-1)*2*pi/n)
+    !
+    !                            where i=sqrt(-1)
+    !
+    !     wsave   contains initialization calculations which must not be
+    !             destroyed between calls of subroutine cfftf or cfftb
+    !
+    subroutine cfftb(n, c, wsave)
+
+        ! Dummy arguments
+        integer(ip), intent(in)    :: n
+        real(wp),    intent(inout) :: c(*)
+        real(wp),    intent(inout) :: wsave(*)
+
+        ! Local variables
+        integer(ip) :: iw1, iw2
+
+        if (n /= 1) then
+            iw1 = 2*n + 1
+            iw2 = iw1 + 2*n
+            call complex_backward_lower_routine(n, c, wsave, wsave(iw1), wsave(iw2))
+        end if
+
+    end subroutine cfftb
+
+    subroutine complex_backward_lower_routine(n, c, ch, wa, ifac)
+
+        ! Dummy arguments
+        integer(ip), intent(in)    :: n
+        real(wp),    intent(inout) :: c(*)
+        real(wp),    intent(in)    :: ifac(*)
+        real(wp) :: ch(*)
+        real(wp) :: wa(*)
+
+        ! Local variables
+        integer(ip) :: nf, na, l1, iw, k1, iip, l2, ido
+        integer(ip) :: idot, idl1, ix2, ix3, ix4, nac, n2
+
+
+        nf = int(ifac(2), kind=ip)
+        na = 0
+        l1 = 1
+        iw = 1
+        do k1 = 1, nf
+            iip = int(ifac(k1+2), kind=ip)
+            l2 = iip*l1
+            ido = n/l2
+            idot = ido + ido
+            idl1 = idot*l1
+
+            select case (iip)
+                case (2)
+                    if (na == 0) then
+                        call complex_backward_pass_2(idot, l1, c, ch, wa(iw))
+                    else
+                        call complex_backward_pass_2(idot, l1, ch, c, wa(iw))
+                    end if
+                    na = 1 - na
+                case (3)
+                    ix2 = iw + idot
+                    if (na == 0) then
+                        call complex_backward_pass_3(idot, l1, c, ch, wa(iw), wa(ix2))
+                    else
+                        call complex_backward_pass_3(idot, l1, ch, c, wa(iw), wa(ix2))
+                    end if
+                    na = 1 - na
+                case (4)
+                    ix2 = iw + idot
+                    ix3 = ix2 + idot
+                    if (na == 0) then
+                        call complex_backward_pass_4(idot, l1, c, ch, wa(iw), wa(ix2), wa(ix3))
+                    else
+                        call complex_backward_pass_4(idot, l1, ch, c, wa(iw), wa(ix2), wa(ix3))
+                    end if
+                    na = 1 - na
+                case (5)
+                    ix2 = iw + idot
+                    ix3 = ix2 + idot
+                    ix4 = ix3 + idot
+                    if (na == 0) then
+                        call complex_backward_pass_5(idot, l1, c, ch, wa(iw), wa(ix2), &
+                            wa(ix3), wa(ix4))
+                    else
+                        call complex_backward_pass_5(idot, l1, ch, c, wa(iw), wa(ix2), &
+                            wa(ix3), wa(ix4))
+                    end if
+                    na = 1 - na
+                case default
+                    if (na == 0) then
+                        call complex_backward_pass_n(nac, idot, iip, l1, idl1, c, c, c, ch, &
+                            ch, wa(iw))
+                    else
+                        call complex_backward_pass_n(nac, idot, iip, l1, idl1, ch, ch, ch, &
+                            c, c, wa(iw))
+                    end if
+                    if (nac /= 0) then
+                        na = 1 - na
+                    end if
+            end select
+            l1 = l2
+            iw = iw + (iip - 1)*idot
+        end do
+
+        if (na /= 0) then
+            n2 = 2*n
+            c(:n2) = ch(:n2)
+        end if
+
+    end subroutine complex_backward_lower_routine
+
+    pure subroutine complex_backward_pass_2(ido, l1, cc, ch, wa1)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 2, l1)
+        real(wp), intent(out) :: ch(ido, l1, 2)
+        real(wp), intent(in) :: wa1(1)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp) :: tr2, ti2
+
+
+        if(ido <= 2) then
+            ch(1,:, 1) = cc(1, 1,:) + cc(1, 2,:)
+            ch(1,:, 2) = cc(1, 1,:) - cc(1, 2,:)
+            ch(2,:, 1) = cc(2, 1,:) + cc(2, 2,:)
+            ch(2,:, 2) = cc(2, 1,:) - cc(2, 2,:)
+        else
+            do k = 1, l1
+                do i = 2, ido, 2
+                    ch(i-1, k, 1) = cc(i-1, 1, k) + cc(i-1, 2, k)
+                    tr2 = cc(i-1, 1, k) - cc(i-1, 2, k)
+                    ch(i, k, 1) = cc(i, 1, k) + cc(i, 2, k)
+                    ti2 = cc(i, 1, k) - cc(i, 2, k)
+                    ch(i, k, 2) = wa1(i-1)*ti2 + wa1(i)*tr2
+                    ch(i-1, k, 2) = wa1(i-1)*tr2 - wa1(i)*ti2
+                end do
+            end do
+        end if
+
+    end subroutine complex_backward_pass_2
+
+    pure subroutine complex_backward_pass_3(ido, l1, cc, ch, wa1, wa2)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in)  :: ido
+        integer(ip), intent(in)  :: l1
+        real(wp),    intent(in)  :: cc(ido, 3, l1)
+        real(wp),    intent(out) :: ch(ido, l1, 3)
+        real(wp),    intent(in)  :: wa1(*)
+        real(wp),    intent(in)  :: wa2(*)
+
+        ! Local variables
+
+        integer(ip)         :: k, i
+        real(wp), parameter :: taur = -HALF
+        real(wp), parameter :: taui = SQRT_3/2 ! 0.866025403784439
+        real(wp)            :: tr2, cr2, ti2, ci2, cr3, ci3, dr2, dr3, di2, di3
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    tr2 = cc(1, 2, k) + cc(1, 3, k)
+                    cr2 = cc(1, 1, k) + taur*tr2
+                    ch(1, k, 1) = cc(1, 1, k) + tr2
+                    ti2 = cc(2, 2, k) + cc(2, 3, k)
+                    ci2 = cc(2, 1, k) + taur*ti2
+                    ch(2, k, 1) = cc(2, 1, k) + ti2
+                    cr3 = taui*(cc(1, 2, k)-cc(1, 3, k))
+                    ci3 = taui*(cc(2, 2, k)-cc(2, 3, k))
+                    ch(1, k, 2) = cr2 - ci3
+                    ch(1, k, 3) = cr2 + ci3
+                    ch(2, k, 2) = ci2 + cr3
+                    ch(2, k, 3) = ci2 - cr3
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        tr2 = cc(i-1, 2, k) + cc(i-1, 3, k)
+                        cr2 = cc(i-1, 1, k) + taur*tr2
+                        ch(i-1, k, 1) = cc(i-1, 1, k) + tr2
+                        ti2 = cc(i, 2, k) + cc(i, 3, k)
+                        ci2 = cc(i, 1, k) + taur*ti2
+                        ch(i, k, 1) = cc(i, 1, k) + ti2
+                        cr3 = taui*(cc(i-1, 2, k)-cc(i-1, 3, k))
+                        ci3 = taui*(cc(i, 2, k)-cc(i, 3, k))
+                        dr2 = cr2 - ci3
+                        dr3 = cr2 + ci3
+                        di2 = ci2 + cr3
+                        di3 = ci2 - cr3
+                        ch(i, k, 2) = wa1(i-1)*di2 + wa1(i)*dr2
+                        ch(i-1, k, 2) = wa1(i-1)*dr2 - wa1(i)*di2
+                        ch(i, k, 3) = wa2(i-1)*di3 + wa2(i)*dr3
+                        ch(i-1, k, 3) = wa2(i-1)*dr3 - wa2(i)*di3
+                    end do
+                end do
+        end select
+
+    end subroutine complex_backward_pass_3
+
+    pure subroutine complex_backward_pass_4(ido, l1, cc, ch, wa1, wa2, wa3)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 4, l1)
+        real(wp), intent(out) :: ch(ido, l1, 4)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp) :: ti1, ti2, tr4, ti3, tr1, tr2, ti4
+        real(wp) :: tr3, cr3, ci3, cr2, cr4, ci2, ci4
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    ti1 = cc(2, 1, k) - cc(2, 3, k)
+                    ti2 = cc(2, 1, k) + cc(2, 3, k)
+                    tr4 = cc(2, 4, k) - cc(2, 2, k)
+                    ti3 = cc(2, 2, k) + cc(2, 4, k)
+                    tr1 = cc(1, 1, k) - cc(1, 3, k)
+                    tr2 = cc(1, 1, k) + cc(1, 3, k)
+                    ti4 = cc(1, 2, k) - cc(1, 4, k)
+                    tr3 = cc(1, 2, k) + cc(1, 4, k)
+                    ch(1, k, 1) = tr2 + tr3
+                    ch(1, k, 3) = tr2 - tr3
+                    ch(2, k, 1) = ti2 + ti3
+                    ch(2, k, 3) = ti2 - ti3
+                    ch(1, k, 2) = tr1 + tr4
+                    ch(1, k, 4) = tr1 - tr4
+                    ch(2, k, 2) = ti1 + ti4
+                    ch(2, k, 4) = ti1 - ti4
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        ti1 = cc(i, 1, k) - cc(i, 3, k)
+                        ti2 = cc(i, 1, k) + cc(i, 3, k)
+                        ti3 = cc(i, 2, k) + cc(i, 4, k)
+                        tr4 = cc(i, 4, k) - cc(i, 2, k)
+                        tr1 = cc(i-1, 1, k) - cc(i-1, 3, k)
+                        tr2 = cc(i-1, 1, k) + cc(i-1, 3, k)
+                        ti4 = cc(i-1, 2, k) - cc(i-1, 4, k)
+                        tr3 = cc(i-1, 2, k) + cc(i-1, 4, k)
+                        ch(i-1, k, 1) = tr2 + tr3
+                        cr3 = tr2 - tr3
+                        ch(i, k, 1) = ti2 + ti3
+                        ci3 = ti2 - ti3
+                        cr2 = tr1 + tr4
+                        cr4 = tr1 - tr4
+                        ci2 = ti1 + ti4
+                        ci4 = ti1 - ti4
+                        ch(i-1, k, 2) = wa1(i-1)*cr2 - wa1(i)*ci2
+                        ch(i, k, 2) = wa1(i-1)*ci2 + wa1(i)*cr2
+                        ch(i-1, k, 3) = wa2(i-1)*cr3 - wa2(i)*ci3
+                        ch(i, k, 3) = wa2(i-1)*ci3 + wa2(i)*cr3
+                        ch(i-1, k, 4) = wa3(i-1)*cr4 - wa3(i)*ci4
+                        ch(i, k, 4) = wa3(i-1)*ci4 + wa3(i)*cr4
+                    end do
+                end do
+        end select
+
+    end subroutine complex_backward_pass_4
+
+    pure subroutine complex_backward_pass_5(ido, l1, cc, ch, wa1, wa2, wa3, wa4)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 5, l1)
+        real(wp), intent(out) :: ch(ido, l1, 5)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+        real(wp), intent(in) :: wa4(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp), parameter :: tr11 = (SQRT_5 - ONE)/4 ! 0.309016994374947
+        real(wp), parameter :: ti11 = (sqrt(ONE/(FIVE + SQRT_5)))/2 ! 0.951056516295154
+        real(wp), parameter :: tr12 = (-ONE - SQRT_5)/4 ! -.809016994374947
+        real(wp), parameter :: ti12 = sqrt( FIVE/(TWO*(FIVE + SQRT_5 ))) ! 0.587785252292473
+        real(wp) ::  ti5, ti2, ti4, ti3, tr5, tr2, tr4
+        real(wp) :: tr3, cr2, ci2, cr3, ci3, cr5, ci5, cr4, ci4, dr3, dr4, di3
+        real(wp) :: di4, dr5, dr2, di5, di2
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    ti5 = cc(2, 2, k) - cc(2, 5, k)
+                    ti2 = cc(2, 2, k) + cc(2, 5, k)
+                    ti4 = cc(2, 3, k) - cc(2, 4, k)
+                    ti3 = cc(2, 3, k) + cc(2, 4, k)
+                    tr5 = cc(1, 2, k) - cc(1, 5, k)
+                    tr2 = cc(1, 2, k) + cc(1, 5, k)
+                    tr4 = cc(1, 3, k) - cc(1, 4, k)
+                    tr3 = cc(1, 3, k) + cc(1, 4, k)
+                    ch(1, k, 1) = cc(1, 1, k) + tr2 + tr3
+                    ch(2, k, 1) = cc(2, 1, k) + ti2 + ti3
+                    cr2 = cc(1, 1, k) + tr11*tr2 + tr12*tr3
+                    ci2 = cc(2, 1, k) + tr11*ti2 + tr12*ti3
+                    cr3 = cc(1, 1, k) + tr12*tr2 + tr11*tr3
+                    ci3 = cc(2, 1, k) + tr12*ti2 + tr11*ti3
+                    cr5 = ti11*tr5 + ti12*tr4
+                    ci5 = ti11*ti5 + ti12*ti4
+                    cr4 = ti12*tr5 - ti11*tr4
+                    ci4 = ti12*ti5 - ti11*ti4
+                    ch(1, k, 2) = cr2 - ci5
+                    ch(1, k, 5) = cr2 + ci5
+                    ch(2, k, 2) = ci2 + cr5
+                    ch(2, k, 3) = ci3 + cr4
+                    ch(1, k, 3) = cr3 - ci4
+                    ch(1, k, 4) = cr3 + ci4
+                    ch(2, k, 4) = ci3 - cr4
+                    ch(2, k, 5) = ci2 - cr5
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        ti5 = cc(i, 2, k) - cc(i, 5, k)
+                        ti2 = cc(i, 2, k) + cc(i, 5, k)
+                        ti4 = cc(i, 3, k) - cc(i, 4, k)
+                        ti3 = cc(i, 3, k) + cc(i, 4, k)
+                        tr5 = cc(i-1, 2, k) - cc(i-1, 5, k)
+                        tr2 = cc(i-1, 2, k) + cc(i-1, 5, k)
+                        tr4 = cc(i-1, 3, k) - cc(i-1, 4, k)
+                        tr3 = cc(i-1, 3, k) + cc(i-1, 4, k)
+                        ch(i-1, k, 1) = cc(i-1, 1, k) + tr2 + tr3
+                        ch(i, k, 1) = cc(i, 1, k) + ti2 + ti3
+                        cr2 = cc(i-1, 1, k) + tr11*tr2 + tr12*tr3
+                        ci2 = cc(i, 1, k) + tr11*ti2 + tr12*ti3
+                        cr3 = cc(i-1, 1, k) + tr12*tr2 + tr11*tr3
+                        ci3 = cc(i, 1, k) + tr12*ti2 + tr11*ti3
+                        cr5 = ti11*tr5 + ti12*tr4
+                        ci5 = ti11*ti5 + ti12*ti4
+                        cr4 = ti12*tr5 - ti11*tr4
+                        ci4 = ti12*ti5 - ti11*ti4
+                        dr3 = cr3 - ci4
+                        dr4 = cr3 + ci4
+                        di3 = ci3 + cr4
+                        di4 = ci3 - cr4
+                        dr5 = cr2 + ci5
+                        dr2 = cr2 - ci5
+                        di5 = ci2 - cr5
+                        di2 = ci2 + cr5
+                        ch(i-1, k, 2) = wa1(i-1)*dr2 - wa1(i)*di2
+                        ch(i, k, 2) = wa1(i-1)*di2 + wa1(i)*dr2
+                        ch(i-1, k, 3) = wa2(i-1)*dr3 - wa2(i)*di3
+                        ch(i, k, 3) = wa2(i-1)*di3 + wa2(i)*dr3
+                        ch(i-1, k, 4) = wa3(i-1)*dr4 - wa3(i)*di4
+                        ch(i, k, 4) = wa3(i-1)*di4 + wa3(i)*dr4
+                        ch(i-1, k, 5) = wa4(i-1)*dr5 - wa4(i)*di5
+                        ch(i, k, 5) = wa4(i-1)*di5 + wa4(i)*dr5
+                    end do
+                end do
+        end select
+
+    end subroutine complex_backward_pass_5
+
+    subroutine complex_backward_pass_n(nac, ido, iip, l1, idl1, cc, c1, c2, ch, ch2, wa)
+
+        ! Dummy arguments
+
+        integer(ip), intent(out) :: nac
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: iip
+        integer(ip), intent(in) :: l1
+        integer(ip), intent(in) :: idl1
+        real(wp), intent(in) :: cc(ido, iip, l1)
+        real(wp), intent(out) :: c1(ido, l1, iip)
+        real(wp), intent(inout)  :: c2(idl1, iip)
+        real(wp), intent(inout)  :: ch(ido, l1, iip)
+        real(wp), intent(inout)  :: ch2(idl1, iip)
+        real(wp), intent(in) :: wa(*)
+
+        ! Local variables
+
+        integer(ip) :: idot, nt, iipp2, iipph, idp, j, jc, k
+        integer(ip) :: i, idl, inc, l, lc, idlj, idij, idj
+        real(wp) :: war, wai
+
+
+        idot = ido/2
+        nt = iip*idl1
+        iipp2 = iip + 2
+        iipph = (iip + 1)/2
+        idp = iip*ido
+
+        if (l1 <= ido) then
+            do j = 2, iipph
+                jc = iipp2 - j
+                ch(:,:, j) = cc(:, j,:) + cc(:, jc,:)
+                ch(:,:, jc) = cc(:, j,:) - cc(:, jc,:)
+            end do
+            ch(:,:, 1) = cc(:, 1,:)
+        else
+            do j = 2, iipph
+                jc = iipp2 - j
+                ch(:,:, j) = cc(:, j,:) + cc(:, jc,:)
+                ch(:,:, jc) = cc(:, j,:) - cc(:, jc,:)
+            end do
+            ch(:,:, 1) = cc(:, 1,:)
+        end if
+
+        idl = 2 - ido
+        inc = 0
+
+        do l = 2, iipph
+            lc = iipp2 - l
+            idl = idl + ido
+            c2(:, l) = ch2(:, 1) + wa(idl-1)*ch2(:, 2)
+            c2(:, lc) = wa(idl)*ch2(:, iip)
+            idlj = idl
+            inc = inc + ido
+            do j = 3, iipph
+                jc = iipp2 - j
+                idlj = idlj + inc
+                if (idlj > idp) idlj = idlj - idp
+                war = wa(idlj-1)
+                wai = wa(idlj)
+                c2(:, l) = c2(:, l) + war*ch2(:, j)
+                c2(:, lc) = c2(:, lc) + wai*ch2(:, jc)
+            end do
+        end do
+
+        do j = 2, iipph
+            ch2(:, 1) = ch2(:, 1) + ch2(:, j)
+        end do
+
+        do j = 2, iipph
+            jc = iipp2 - j
+            ch2(:idl1-1:2, j) = c2(:idl1-1:2, j) - c2(2:idl1:2, jc)
+            ch2(:idl1-1:2, jc) = c2(:idl1-1:2, j) + c2(2:idl1:2, jc)
+            ch2(2:idl1:2, j) = c2(2:idl1:2, j) + c2(:idl1-1:2, jc)
+            ch2(2:idl1:2, jc) = c2(2:idl1:2, j) - c2(:idl1-1:2, jc)
+        end do
+
+        nac = 1
+
+        if(ido /= 2) then
+            nac = 0
+            c2(:, 1) = ch2(:, 1)
+            c1(1,:, 2:iip) = ch(1,:, 2:iip)
+            c1(2,:, 2:iip) = ch(2,:, 2:iip)
+
+            if(idot <= l1) then
+                idij = 0
+                do j = 2, iip
+                    idij = idij + 2
+                    do i = 4, ido, 2
+                        idij = idij + 2
+                        c1(i-1,:, j) = wa(idij-1)*ch(i-1,:, j) - wa(idij)*ch(i,:, j)
+                        c1(i,:, j) = wa(idij-1)*ch(i,:, j) + wa(idij)*ch(i-1,:, j)
+                    end do
+                end do
+            else
+                idj = 2 - ido
+                do j = 2, iip
+                    idj = idj + ido
+                    do k = 1, l1
+                        idij = idj
+                        c1(3:ido-1:2, k, j) = wa(idij+1:ido-3+idij:2)*ch(3:ido-1:2, k, j &
+                            ) - wa(idij+2:ido-2+idij:2)*ch(4:ido:2, k, j)
+                        c1(4:ido:2, k, j) = wa(idij+1:ido-3+idij:2)*ch(4:ido:2, k, j) + &
+                            wa(idij+2:ido-2+idij:2)*ch(3:ido-1:2, k, j)
+                    end do
+                end do
+            end if
+        end if
+
+    end subroutine complex_backward_pass_n
+
+    subroutine cfftf(n, c, wsave)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in)      :: n
+        real(wp),    intent(inout)   :: c(*)
+        real(wp),    intent(inout)   :: wsave(*)
+
+        ! Local variables
+
+        integer(ip) :: iw1, iw2
+
+
+        if (n /= 1) then
+            iw1 = 2*n + 1
+            iw2 = iw1 + 2*n
+            call complex_forward_lower_routine(n, c, wsave, wsave(iw1), wsave(iw2))
+        end if
+
+    end subroutine cfftf
+
+    subroutine complex_forward_lower_routine(n, c, ch, wa, ifac)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in)     :: n
+        real(wp),    intent(inout)  :: c(*)
+        real(wp),    intent(inout)  :: ch(*)
+        real(wp),    intent(in)     :: wa(*)
+        real(wp),    intent(in)     :: ifac(*)
+
+        ! Local variables
+
+        integer(ip) :: nf, na, l1, iw, k1, iip, l2, ido
+        integer(ip) :: idot, idl1, ix2, ix3, ix4, nac, n2
+
+
+        nf = int(ifac(2), kind=ip)
+        na = 0
+        l1 = 1
+        iw = 1
+
+        do k1 = 1, nf
+            iip = int(ifac(k1+2), kind=ip)
+            l2 = iip*l1
+            ido = n/l2
+            idot = ido + ido
+            idl1 = idot*l1
+
+            select case (iip)
+                case (2)
+                    if (na == 0) then
+                        call complex_forward_pass_2(idot, l1, c, ch, wa(iw))
+                    else
+                        call complex_forward_pass_2(idot, l1, ch, c, wa(iw))
+                    end if
+                    na = 1 - na
+                case (3)
+                    ix2 = iw + idot
+                    if (na == 0) then
+                        call complex_forward_pass_3(idot, l1, c, ch, wa(iw), wa(ix2))
+                    else
+                        call complex_forward_pass_3(idot, l1, ch, c, wa(iw), wa(ix2))
+                    end if
+                    na = 1 - na
+                case (4)
+                    ix3 = ix2 + idot
+                    if (na == 0) then
+                        call complex_forward_pass_4(idot, l1, c, ch, wa(iw), wa(ix2), wa(ix3))
+                    else
+                        call complex_forward_pass_4(idot, l1, ch, c, wa(iw), wa(ix2), wa(ix3))
+                    end if
+                    na = 1 - na
+                case (5)
+                    ix2 = iw + idot
+                    ix3 = ix2 + idot
+                    ix4 = ix3 + idot
+                    if (na == 0) then
+                        call complex_forward_pass_5(idot, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4))
+                    else
+                        call complex_forward_pass_5(idot, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4))
+                    end if
+                    na = 1 - na
+                case default
+                    if (na == 0) then
+                        call complex_forward_pass_n(nac, idot, iip, l1, idl1, c, c, c, ch, ch, wa(iw))
+                    else
+                        call complex_forward_pass_n(nac, idot, iip, l1, idl1, ch, ch, ch, c, c, wa(iw))
+                    end if
+                    if (nac /= 0) na = 1 - na
+            end select
+            l1 = l2
+            iw = iw + (iip - 1)*idot
+        end do
+
+        if (na /= 0) then
+            n2 = n + n
+            c(:n2) = ch(:n2)
+        end if
+
+    end subroutine complex_forward_lower_routine
+
+
+    pure subroutine complex_forward_pass_2(ido, l1, cc, ch, wa1)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 2, l1)
+        real(wp), intent(out) :: ch(ido, l1, 2)
+        real(wp), intent(in) :: wa1(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp) :: tr2, ti2
+
+
+        if(ido <= 2) then
+            ch(1,:, 1) = cc(1, 1,:) + cc(1, 2,:)
+            ch(1,:, 2) = cc(1, 1,:) - cc(1, 2,:)
+            ch(2,:, 1) = cc(2, 1,:) + cc(2, 2,:)
+            ch(2,:, 2) = cc(2, 1,:) - cc(2, 2,:)
+        else
+            do k = 1, l1
+                do i = 2, ido, 2
+                    ch(i-1, k, 1) = cc(i-1, 1, k) + cc(i-1, 2, k)
+                    tr2 = cc(i-1, 1, k) - cc(i-1, 2, k)
+                    ch(i, k, 1) = cc(i, 1, k) + cc(i, 2, k)
+                    ti2 = cc(i, 1, k) - cc(i, 2, k)
+                    ch(i, k, 2) = wa1(i-1)*ti2 - wa1(i)*tr2
+                    ch(i-1, k, 2) = wa1(i-1)*tr2 + wa1(i)*ti2
+                end do
+            end do
+        end if
+
+    end subroutine complex_forward_pass_2
+
+
+    pure subroutine complex_forward_pass_3(ido, l1, cc, ch, wa1, wa2)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 3, l1)
+        real(wp), intent(out) :: ch(ido, l1, 3)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp), parameter :: taur = -HALF
+        real(wp), parameter :: taui = -sqrt(THREE)/2 !  - 0.866025403784439
+        real(wp) :: tr2, cr2, ti2, ci2, cr3, ci3, dr2, dr3, di2, di3
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    tr2 = cc(1, 2, k) + cc(1, 3, k)
+                    cr2 = cc(1, 1, k) + taur*tr2
+                    ch(1, k, 1) = cc(1, 1, k) + tr2
+                    ti2 = cc(2, 2, k) + cc(2, 3, k)
+                    ci2 = cc(2, 1, k) + taur*ti2
+                    ch(2, k, 1) = cc(2, 1, k) + ti2
+                    cr3 = taui*(cc(1, 2, k)-cc(1, 3, k))
+                    ci3 = taui*(cc(2, 2, k)-cc(2, 3, k))
+                    ch(1, k, 2) = cr2 - ci3
+                    ch(1, k, 3) = cr2 + ci3
+                    ch(2, k, 2) = ci2 + cr3
+                    ch(2, k, 3) = ci2 - cr3
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        tr2 = cc(i-1, 2, k) + cc(i-1, 3, k)
+                        cr2 = cc(i-1, 1, k) + taur*tr2
+                        ch(i-1, k, 1) = cc(i-1, 1, k) + tr2
+                        ti2 = cc(i, 2, k) + cc(i, 3, k)
+                        ci2 = cc(i, 1, k) + taur*ti2
+                        ch(i, k, 1) = cc(i, 1, k) + ti2
+                        cr3 = taui*(cc(i-1, 2, k)-cc(i-1, 3, k))
+                        ci3 = taui*(cc(i, 2, k)-cc(i, 3, k))
+                        dr2 = cr2 - ci3
+                        dr3 = cr2 + ci3
+                        di2 = ci2 + cr3
+                        di3 = ci2 - cr3
+                        ch(i, k, 2) = wa1(i-1)*di2 - wa1(i)*dr2
+                        ch(i-1, k, 2) = wa1(i-1)*dr2 + wa1(i)*di2
+                        ch(i, k, 3) = wa2(i-1)*di3 - wa2(i)*dr3
+                        ch(i-1, k, 3) = wa2(i-1)*dr3 + wa2(i)*di3
+                    end do
+                end do
+        end select
+
+    end subroutine complex_forward_pass_3
+
+    pure subroutine complex_forward_pass_4(ido, l1, cc, ch, wa1, wa2, wa3)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 4, l1)
+        real(wp), intent(out) :: ch(ido, l1, 4)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp) :: ti1, ti2, tr4, ti3, tr1, tr2, ti4
+        real(wp) :: tr3, cr3, ci3, cr2, cr4, ci2, ci4
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    ti1 = cc(2, 1, k) - cc(2, 3, k)
+                    ti2 = cc(2, 1, k) + cc(2, 3, k)
+                    tr4 = cc(2, 2, k) - cc(2, 4, k)
+                    ti3 = cc(2, 2, k) + cc(2, 4, k)
+                    tr1 = cc(1, 1, k) - cc(1, 3, k)
+                    tr2 = cc(1, 1, k) + cc(1, 3, k)
+                    ti4 = cc(1, 4, k) - cc(1, 2, k)
+                    tr3 = cc(1, 2, k) + cc(1, 4, k)
+                    ch(1, k, 1) = tr2 + tr3
+                    ch(1, k, 3) = tr2 - tr3
+                    ch(2, k, 1) = ti2 + ti3
+                    ch(2, k, 3) = ti2 - ti3
+                    ch(1, k, 2) = tr1 + tr4
+                    ch(1, k, 4) = tr1 - tr4
+                    ch(2, k, 2) = ti1 + ti4
+                    ch(2, k, 4) = ti1 - ti4
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        ti1 = cc(i, 1, k) - cc(i, 3, k)
+                        ti2 = cc(i, 1, k) + cc(i, 3, k)
+                        ti3 = cc(i, 2, k) + cc(i, 4, k)
+                        tr4 = cc(i, 2, k) - cc(i, 4, k)
+                        tr1 = cc(i-1, 1, k) - cc(i-1, 3, k)
+                        tr2 = cc(i-1, 1, k) + cc(i-1, 3, k)
+                        ti4 = cc(i-1, 4, k) - cc(i-1, 2, k)
+                        tr3 = cc(i-1, 2, k) + cc(i-1, 4, k)
+                        ch(i-1, k, 1) = tr2 + tr3
+                        cr3 = tr2 - tr3
+                        ch(i, k, 1) = ti2 + ti3
+                        ci3 = ti2 - ti3
+                        cr2 = tr1 + tr4
+                        cr4 = tr1 - tr4
+                        ci2 = ti1 + ti4
+                        ci4 = ti1 - ti4
+                        ch(i-1, k, 2) = wa1(i-1)*cr2 + wa1(i)*ci2
+                        ch(i, k, 2) = wa1(i-1)*ci2 - wa1(i)*cr2
+                        ch(i-1, k, 3) = wa2(i-1)*cr3 + wa2(i)*ci3
+                        ch(i, k, 3) = wa2(i-1)*ci3 - wa2(i)*cr3
+                        ch(i-1, k, 4) = wa3(i-1)*cr4 + wa3(i)*ci4
+                        ch(i, k, 4) = wa3(i-1)*ci4 - wa3(i)*cr4
+                    end do
+                end do
+        end select
+
+    end subroutine complex_forward_pass_4
+
+    pure subroutine complex_forward_pass_5(ido, l1, cc, ch, wa1, wa2, wa3, wa4)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 5, l1)
+        real(wp), intent(out) :: ch(ido, l1, 5)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+        real(wp), intent(in) :: wa4(*)
+
+        ! Local variables
+
+        integer(ip) :: k, i
+        real(wp) :: ti5, ti2, ti4, ti3, tr5, tr2, tr4
+        real(wp) :: tr3, cr2, ci2, cr3, ci3, cr5, ci5, cr4, ci4, dr3, dr4, di3
+        real(wp) :: di4, dr5, dr2, di5, di2
+        real(wp), parameter :: tr11 = (SQRT_5 - ONE)/4 ! 0.309016994374947
+        real(wp), parameter :: ti11 = -sqrt((FIVE + SQRT_5)/2)/2 ! -.951056516295154
+        real(wp), parameter :: tr12 = (-ONE - SQRT_5)/4 ! -.809016994374947
+        real(wp), parameter :: ti12 = -sqrt(FIVE/(TWO * (FIVE + SQRT_5)) ) ! -0.587785252292473
+
+
+        select case(ido)
+            case (2)
+                do k = 1, l1
+                    ti5 = cc(2, 2, k) - cc(2, 5, k)
+                    ti2 = cc(2, 2, k) + cc(2, 5, k)
+                    ti4 = cc(2, 3, k) - cc(2, 4, k)
+                    ti3 = cc(2, 3, k) + cc(2, 4, k)
+                    tr5 = cc(1, 2, k) - cc(1, 5, k)
+                    tr2 = cc(1, 2, k) + cc(1, 5, k)
+                    tr4 = cc(1, 3, k) - cc(1, 4, k)
+                    tr3 = cc(1, 3, k) + cc(1, 4, k)
+                    ch(1, k, 1) = cc(1, 1, k) + tr2 + tr3
+                    ch(2, k, 1) = cc(2, 1, k) + ti2 + ti3
+                    cr2 = cc(1, 1, k) + tr11*tr2 + tr12*tr3
+                    ci2 = cc(2, 1, k) + tr11*ti2 + tr12*ti3
+                    cr3 = cc(1, 1, k) + tr12*tr2 + tr11*tr3
+                    ci3 = cc(2, 1, k) + tr12*ti2 + tr11*ti3
+                    cr5 = ti11*tr5 + ti12*tr4
+                    ci5 = ti11*ti5 + ti12*ti4
+                    cr4 = ti12*tr5 - ti11*tr4
+                    ci4 = ti12*ti5 - ti11*ti4
+                    ch(1, k, 2) = cr2 - ci5
+                    ch(1, k, 5) = cr2 + ci5
+                    ch(2, k, 2) = ci2 + cr5
+                    ch(2, k, 3) = ci3 + cr4
+                    ch(1, k, 3) = cr3 - ci4
+                    ch(1, k, 4) = cr3 + ci4
+                    ch(2, k, 4) = ci3 - cr4
+                    ch(2, k, 5) = ci2 - cr5
+                end do
+            case default
+                do k = 1, l1
+                    do i = 2, ido, 2
+                        ti5 = cc(i, 2, k) - cc(i, 5, k)
+                        ti2 = cc(i, 2, k) + cc(i, 5, k)
+                        ti4 = cc(i, 3, k) - cc(i, 4, k)
+                        ti3 = cc(i, 3, k) + cc(i, 4, k)
+                        tr5 = cc(i-1, 2, k) - cc(i-1, 5, k)
+                        tr2 = cc(i-1, 2, k) + cc(i-1, 5, k)
+                        tr4 = cc(i-1, 3, k) - cc(i-1, 4, k)
+                        tr3 = cc(i-1, 3, k) + cc(i-1, 4, k)
+                        ch(i-1, k, 1) = cc(i-1, 1, k) + tr2 + tr3
+                        ch(i, k, 1) = cc(i, 1, k) + ti2 + ti3
+                        cr2 = cc(i-1, 1, k) + tr11*tr2 + tr12*tr3
+                        ci2 = cc(i, 1, k) + tr11*ti2 + tr12*ti3
+                        cr3 = cc(i-1, 1, k) + tr12*tr2 + tr11*tr3
+                        ci3 = cc(i, 1, k) + tr12*ti2 + tr11*ti3
+                        cr5 = ti11*tr5 + ti12*tr4
+                        ci5 = ti11*ti5 + ti12*ti4
+                        cr4 = ti12*tr5 - ti11*tr4
+                        ci4 = ti12*ti5 - ti11*ti4
+                        dr3 = cr3 - ci4
+                        dr4 = cr3 + ci4
+                        di3 = ci3 + cr4
+                        di4 = ci3 - cr4
+                        dr5 = cr2 + ci5
+                        dr2 = cr2 - ci5
+                        di5 = ci2 - cr5
+                        di2 = ci2 + cr5
+                        ch(i-1, k, 2) = wa1(i-1)*dr2 + wa1(i)*di2
+                        ch(i, k, 2) = wa1(i-1)*di2 - wa1(i)*dr2
+                        ch(i-1, k, 3) = wa2(i-1)*dr3 + wa2(i)*di3
+                        ch(i, k, 3) = wa2(i-1)*di3 - wa2(i)*dr3
+                        ch(i-1, k, 4) = wa3(i-1)*dr4 + wa3(i)*di4
+                        ch(i, k, 4) = wa3(i-1)*di4 - wa3(i)*dr4
+                        ch(i-1, k, 5) = wa4(i-1)*dr5 + wa4(i)*di5
+                        ch(i, k, 5) = wa4(i-1)*di5 - wa4(i)*dr5
+                    end do
+                end do
+        end select
+
+    end subroutine complex_forward_pass_5
+
+    subroutine complex_forward_pass_n(nac, ido, iip, l1, idl1, cc, c1, c2, ch, ch2, wa)
+
+        ! Dummy arguments
+
+        integer(ip), intent(out)    :: nac
+        integer(ip), intent(in)     :: ido
+        integer(ip), intent(in)     :: iip
+        integer(ip), intent(in)     :: l1
+        integer(ip), intent(in)     :: idl1
+        real(wp),    intent(inout)  :: cc(ido, iip, l1)
+        real(wp),    intent(inout)  :: c1(ido, l1, iip)
+        real(wp),    intent(inout)  :: c2(idl1, iip)
+        real(wp),    intent(inout)  :: ch(ido, l1, iip)
+        real(wp),    intent(inout)  :: ch2(idl1, iip)
+        real(wp),    intent(in)     :: wa(*)
+
+        ! Local variables
+
+        integer(ip) :: idot, nt, iipp2, iipph, idp, j, jc
+        integer(ip) :: k, i, idl, inc, l, lc
+        integer(ip) :: idlj, idij, idj
+        real(wp)    :: war, wai
+
+
+        idot = ido/2
+        nt = iip*idl1
+        iipp2 = iip + 2
+        iipph = (iip + 1)/2
+        idp = iip*ido
+
+        if (l1 <= ido) then
+            do j = 2, iipph
+                jc = iipp2 - j
+                ch(:,:, j) = cc(:, j,:) + cc(:, jc,:)
+                ch(:,:, jc) = cc(:, j,:) - cc(:, jc,:)
+            end do
+            ch(:,:, 1) = cc(:, 1,:)
+        else
+            do j = 2, iipph
+                jc = iipp2 - j
+                ch(:,:, j) = cc(:, j,:) + cc(:, jc,:)
+                ch(:,:, jc) = cc(:, j,:) - cc(:, jc,:)
+            end do
+            ch(:,:, 1) = cc(:, 1,:)
+        end if
+
+        idl = 2 - ido
+        inc = 0
+
+        do l = 2, iipph
+            lc = iipp2 - l
+            idl = idl + ido
+            c2(:, l) = ch2(:, 1) + wa(idl-1)*ch2(:, 2)
+            c2(:, lc) = -wa(idl)*ch2(:, iip)
+            idlj = idl
+            inc = inc + ido
+            do j = 3, iipph
+                jc = iipp2 - j
+                idlj = idlj + inc
+                if (idlj > idp) then
+                    idlj = idlj - idp
+                end if
+                war = wa(idlj-1)
+                wai = wa(idlj)
+                c2(:, l) = c2(:, l) + war*ch2(:, j)
+                c2(:, lc) = c2(:, lc) - wai*ch2(:, jc)
+            end do
+        end do
+
+        do j = 2, iipph
+            ch2(:, 1) = ch2(:, 1) + ch2(:, j)
+        end do
+
+        do j = 2, iipph
+            jc = iipp2 - j
+            ch2(:idl1-1:2, j) = c2(:idl1-1:2, j) - c2(2:idl1:2, jc)
+            ch2(:idl1-1:2, jc) = c2(:idl1-1:2, j) + c2(2:idl1:2, jc)
+            ch2(2:idl1:2, j) = c2(2:idl1:2, j) + c2(:idl1-1:2, jc)
+            ch2(2:idl1:2, jc) = c2(2:idl1:2, j) - c2(:idl1-1:2, jc)
+        end do
+
+        nac = 1
+
+        if (ido /= 2) then
+
+            nac = 0
+            c2(:, 1) = ch2(:, 1)
+            c1(1,:, 2:iip) = ch(1,:, 2:iip)
+            c1(2,:, 2:iip) = ch(2,:, 2:iip)
+
+            if (idot <= l1) then
+                idij = 0
+                do j = 2, iip
+                    idij = idij + 2
+                    do i = 4, ido, 2
+                        idij = idij + 2
+                        c1(i-1,:, j) = wa(idij-1)*ch(i-1,:, j) + wa(idij)*ch(i,:, j)
+                        c1(i,:, j) = wa(idij-1)*ch(i,:, j) - wa(idij)*ch(i-1,:, j)
+                    end do
+                end do
+            else
+                idj = 2 - ido
+                do j = 2, iip
+                    idj = idj + ido
+                    do k = 1, l1
+                        idij = idj
+                        c1(3:ido-1:2, k, j) = wa(idij+1:ido-3+idij:2)*ch(3:ido-1:2, k, j &
+                            ) + wa(idij+2:ido-2+idij:2)*ch(4:ido:2, k, j)
+                        c1(4:ido:2, k, j) = wa(idij+1:ido-3+idij:2)*ch(4:ido:2, k, j) - &
+                            wa(idij+2:ido-2+idij:2)*ch(3:ido-1:2, k, j)
+                    end do
+                end do
+            end if
+        end if
+
+    end subroutine complex_forward_pass_n
+
+    !     subroutine rffti(n, wsave)
+    !
+    ! Purpose:
+    !
+    !     Initializes the array wsave which is used in
+    !     both rfftf and rfftb. the prime factorization of n together with
+    !     a tabulation of the trigonometric functions are computed and
+    !     stored in wsave.
+    !
+    !     input parameter
+    !
+    !     n       the length of the sequence to be transformed.
+    !
+    !     output parameter
+    !
+    !     wsave   a work array which must be dimensioned at least 2*n+15.
+    !             the same work array can be used for both rfftf and rfftb
+    !             as long as n remains unchanged. different wsave arrays
+    !             are required for different values of n. the contents of
+    !             wsave must not be changed between calls of rfftf or rfftb.
+    !
+    pure subroutine rffti(n, wsave)
+
+        ! Dummy arguments
+        integer(ip), intent(in)  :: n
+        real(wp),    intent(out) :: wsave(*)
+
+        if (n /= 1) then
+            call real_initialization_lower_routine(n, wsave(n+1), wsave(2*n+1))
+        end if
+
+    end subroutine rffti
+
+    pure subroutine real_initialization_lower_routine(n, wa, ifac)
+
+        ! Dummy arguments
+        integer(ip),  intent(in)  :: n
+        real(wp),     intent(out) :: ifac(*)
+        real(wp),     intent(out) :: wa(*)
+
+        ! Local variables
+        integer, parameter :: NTRYH(*) = [4, 2, 3, 5]
+        integer(ip)        :: nl, nf, j, ntry, nq, nr, i, is, nfm1, l1, k1, iip
+        integer(ip)        :: ld, l2, ido, iipm, ii
+        real(wp)           :: argh, argld, fi, arg
+
+        ! Initialize values
+        ntry = 0
+        nl = n
+        nf = 0
+        j = 0
+
+        factorization_loop: do
+
+            j = j + 1
+
+            if (j <= 4) then
+                ntry = NTRYH(j)
+            else
+                ntry = ntry + 2
+            end if
+
+            inner_loop: do
+
+                nq = nl/ntry
+                nr = nl - ntry*nq
+
+                if (nr /= 0) cycle factorization_loop
+
+                nf = nf + 1
+                ifac(nf+2) = ntry
+                nl = nq
+
+                if (ntry == 2) then
+                    if (nf /= 1) then
+                        ifac(nf+2:4:(-1)) = ifac(nf+1:3:(-1))
+                        ifac(3) = 2
+                    end if
+                end if
+
+                if (nl /= 1) cycle inner_loop
+
+                exit inner_loop
+            end do inner_loop
+            exit factorization_loop
+        end do factorization_loop
+
+        ifac(1) = n
+        ifac(2) = nf
+        argh = TWO_PI/n
+        is = 0
+        nfm1 = nf - 1
+        l1 = 1
+
+        if (nfm1 /= 0) then
+            do k1 = 1, nfm1
+                iip = int(ifac(k1+2), kind=ip)
+                ld = 0
+                l2 = l1*iip
+                ido = n/l2
+                iipm = iip - 1
+                do j = 1, iipm
+                    ld = ld + l1
+                    i = is
+                    argld = real(ld, kind=wp)*argh
+                    fi = ZERO
+                    do ii = 3, ido, 2
+                        i = i + 2
+                        fi = fi + ONE
+                        arg = fi*argld
+                        wa(i-1) = cos(arg)
+                        wa(i) = sin(arg)
+                    end do
+                    is = is + ido
+                end do
+                l1 = l2
+            end do
+        end if
+
+    end subroutine real_initialization_lower_routine
+
+    subroutine rfftb(n, r, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: r(*)
+        real(wp) :: wsave(*)
+
+
+        if (n /= 1) then
+            call real_backward_lower_routine(n, r, wsave, wsave(n+1), wsave(2*n+1))
+        end if
+
+    end subroutine rfftb
+
+    subroutine real_backward_lower_routine(n, c, ch, wa, ifac)
+
+        ! Dummy arguments
+
+        integer(ip),  intent(in) :: n
+        real(wp), intent(in) :: ifac(*)
+        real(wp)              :: c(*)
+        real(wp)              :: ch(*)
+        real(wp)              :: wa(*)
+
+        ! Local variables
+
+        integer(ip) :: nf, na, l1, iw, k1, iip
+        integer(ip) :: l2, ido, idl1, ix2, ix3, ix4
+
+
+        nf = int(ifac(2), kind=ip)
+        na = 0
+        l1 = 1
+        iw = 1
+
+        do k1 = 1, nf
+            iip = int(ifac(k1+2), kind=ip)
+            l2 = iip*l1
+            ido = n/l2
+            idl1 = ido*l1
+
+            select case (iip)
+                case (4)
+                    ix2 = iw + ido
+                    ix3 = ix2 + ido
+                    if (na == 0) then
+                        call real_backward_pass_4(ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3))
+                    else
+                        call real_backward_pass_4(ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3))
+                    end if
+                    na = 1 - na
+                case (2)
+                    if (na == 0) then
+                        call real_backward_pass_2(ido, l1, c, ch, wa(iw))
+                    else
+                        call real_backward_pass_2(ido, l1, ch, c, wa(iw))
+                    end if
+                    na = 1 - na
+                case (3)
+                    ix2 = iw + ido
+                    if (na == 0) then
+                        call real_backward_pass_3(ido, l1, c, ch, wa(iw), wa(ix2))
+                    else
+                        call real_backward_pass_3(ido, l1, ch, c, wa(iw), wa(ix2))
+                    end if
+                    na = 1 - na
+                case (5)
+                    ix2 = iw + ido
+                    ix3 = ix2 + ido
+                    ix4 = ix3 + ido
+                    if (na == 0) then
+                        call real_backward_pass_5(ido, l1, c, ch, wa(iw), wa(ix2), wa( &
+                            ix3), wa(ix4))
+                    else
+                        call real_backward_pass_5(ido, l1, ch, c, wa(iw), wa(ix2), wa( &
+                            ix3), wa(ix4))
+                    end if
+                    na = 1 - na
+                case default
+                    if (na == 0) then
+                        call real_backward_pass_n(ido, iip, l1, idl1, c, c, c, ch, ch, wa(iw))
+                    else
+                        call real_backward_pass_n(ido, iip, l1, idl1, ch, ch, ch, c, c, wa(iw))
+                    end if
+
+                    if (ido == 1) na = 1 - na
+
+            end select
+            l1 = l2
+            iw = iw + (iip - 1)*ido
+        end do
+
+        if (na /= 0) c(:n) = ch(:n)
+
+    end subroutine real_backward_lower_routine
+
+    pure subroutine real_backward_pass_2(ido, l1, cc, ch, wa1)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 2, l1)
+        real(wp), intent(out) :: ch(ido, l1, 2)
+        real(wp), intent(in) :: wa1(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp) :: tr2, ti2
+
+
+        ch(1,:, 1) = cc(1, 1,:) + cc(ido, 2,:)
+        ch(1,:, 2) = cc(1, 1,:) - cc(ido, 2,:)
+
+        if (ido >= 2) then
+            if (ido /= 2) then
+                idp2 = ido + 2
+                do k = 1, l1
+                    do i = 3, ido, 2
+                        ic = idp2 - i
+                        ch(i-1, k, 1) = cc(i-1, 1, k) + cc(ic-1, 2, k)
+                        tr2 = cc(i-1, 1, k) - cc(ic-1, 2, k)
+                        ch(i, k, 1) = cc(i, 1, k) - cc(ic, 2, k)
+                        ti2 = cc(i, 1, k) + cc(ic, 2, k)
+                        ch(i-1, k, 2) = wa1(i-2)*tr2 - wa1(i-1)*ti2
+                        ch(i, k, 2) = wa1(i-2)*ti2 + wa1(i-1)*tr2
+                    end do
+                end do
+                if (mod(ido, 2) == 1) then
+                    return
+                end if
+            end if
+            ch(ido,:, 1) = cc(ido, 1,:) + cc(ido, 1,:)
+            ch(ido,:, 2) = -(cc(1, 2,:)+cc(1, 2,:))
+        end if
+
+    end subroutine real_backward_pass_2
+
+    pure subroutine real_backward_pass_3(ido, l1, cc, ch, wa1, wa2)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 3, l1)
+        real(wp), intent(out) :: ch(ido, l1, 3)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp), parameter :: taur = -HALF
+        real(wp), parameter :: taui = sqrt(THREE)/TWO ! 0.866025403784439
+        real(wp)            :: tr2, cr2, ci3, ti2, ci2, cr3, dr2, dr3, di2, di3
+
+
+        do k = 1, l1
+            tr2 = cc(ido, 2, k) + cc(ido, 2, k)
+            cr2 = cc(1, 1, k) + taur*tr2
+            ch(1, k, 1) = cc(1, 1, k) + tr2
+            ci3 = taui*(cc(1, 3, k)+cc(1, 3, k))
+            ch(1, k, 2) = cr2 - ci3
+            ch(1, k, 3) = cr2 + ci3
+        end do
+
+        if(ido /= 1) then
+            idp2 = ido + 2
+            do k = 1, l1
+                do i = 3, ido, 2
+                    ic = idp2 - i
+                    tr2 = cc(i-1, 3, k) + cc(ic-1, 2, k)
+                    cr2 = cc(i-1, 1, k) + taur*tr2
+                    ch(i-1, k, 1) = cc(i-1, 1, k) + tr2
+                    ti2 = cc(i, 3, k) - cc(ic, 2, k)
+                    ci2 = cc(i, 1, k) + taur*ti2
+                    ch(i, k, 1) = cc(i, 1, k) + ti2
+                    cr3 = taui*(cc(i-1, 3, k)-cc(ic-1, 2, k))
+                    ci3 = taui*(cc(i, 3, k)+cc(ic, 2, k))
+                    dr2 = cr2 - ci3
+                    dr3 = cr2 + ci3
+                    di2 = ci2 + cr3
+                    di3 = ci2 - cr3
+                    ch(i-1, k, 2) = wa1(i-2)*dr2 - wa1(i-1)*di2
+                    ch(i, k, 2) = wa1(i-2)*di2 + wa1(i-1)*dr2
+                    ch(i-1, k, 3) = wa2(i-2)*dr3 - wa2(i-1)*di3
+                    ch(i, k, 3) = wa2(i-2)*di3 + wa2(i-1)*dr3
+                end do
+            end do
+        end if
+
+    end subroutine real_backward_pass_3
+
+    pure subroutine real_backward_pass_4(ido, l1, cc, ch, wa1, wa2, wa3)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 4, l1)
+        real(wp), intent(out) :: ch(ido, l1, 4)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+
+        ! Local variables
+
+        integer(ip)         :: k, idp2, i, ic
+        real(wp), parameter :: SQRT_2 = sqrt(TWO) ! 1.414213562373095
+        real(wp)            :: tr1, tr2, tr3, tr4, ti1, ti2, ti3, ti4, cr3, ci3
+        real(wp)            :: cr2, cr4, ci2, ci4
+
+
+        do k = 1, l1
+            tr1 = cc(1, 1, k) - cc(ido, 4, k)
+            tr2 = cc(1, 1, k) + cc(ido, 4, k)
+            tr3 = cc(ido, 2, k) + cc(ido, 2, k)
+            tr4 = cc(1, 3, k) + cc(1, 3, k)
+            ch(1, k, 1) = tr2 + tr3
+            ch(1, k, 2) = tr1 - tr4
+            ch(1, k, 3) = tr2 - tr3
+            ch(1, k, 4) = tr1 + tr4
+        end do
+
+        if (2 <= ido) then
+            if (ido /= 2) then
+                idp2 = ido + 2
+                do k = 1, l1
+                    do i = 3, ido, 2
+                        ic = idp2 - i
+                        ti1 = cc(i, 1, k) + cc(ic, 4, k)
+                        ti2 = cc(i, 1, k) - cc(ic, 4, k)
+                        ti3 = cc(i, 3, k) - cc(ic, 2, k)
+                        tr4 = cc(i, 3, k) + cc(ic, 2, k)
+                        tr1 = cc(i-1, 1, k) - cc(ic-1, 4, k)
+                        tr2 = cc(i-1, 1, k) + cc(ic-1, 4, k)
+                        ti4 = cc(i-1, 3, k) - cc(ic-1, 2, k)
+                        tr3 = cc(i-1, 3, k) + cc(ic-1, 2, k)
+                        ch(i-1, k, 1) = tr2 + tr3
+                        cr3 = tr2 - tr3
+                        ch(i, k, 1) = ti2 + ti3
+                        ci3 = ti2 - ti3
+                        cr2 = tr1 - tr4
+                        cr4 = tr1 + tr4
+                        ci2 = ti1 + ti4
+                        ci4 = ti1 - ti4
+                        ch(i-1, k, 2) = wa1(i-2)*cr2 - wa1(i-1)*ci2
+                        ch(i, k, 2) = wa1(i-2)*ci2 + wa1(i-1)*cr2
+                        ch(i-1, k, 3) = wa2(i-2)*cr3 - wa2(i-1)*ci3
+                        ch(i, k, 3) = wa2(i-2)*ci3 + wa2(i-1)*cr3
+                        ch(i-1, k, 4) = wa3(i-2)*cr4 - wa3(i-1)*ci4
+                        ch(i, k, 4) = wa3(i-2)*ci4 + wa3(i-1)*cr4
+                    end do
+                end do
+                if (mod(ido, 2) == 1) then
+                    return
+                end if
+            end if
+            do k = 1, l1
+                ti1 = cc(1, 2, k) + cc(1, 4, k)
+                ti2 = cc(1, 4, k) - cc(1, 2, k)
+                tr1 = cc(ido, 1, k) - cc(ido, 3, k)
+                tr2 = cc(ido, 1, k) + cc(ido, 3, k)
+                ch(ido, k, 1) = tr2 + tr2
+                ch(ido, k, 2) = SQRT_2*(tr1 - ti1)
+                ch(ido, k, 3) = ti2 + ti2
+                ch(ido, k, 4) = -SQRT_2*(tr1 + ti1)
+            end do
+        end if
+
+    end subroutine real_backward_pass_4
+
+    pure subroutine real_backward_pass_5(ido, l1, cc, ch, wa1, wa2, wa3, wa4)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, 5, l1)
+        real(wp), intent(out) :: ch(ido, l1, 5)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+        real(wp), intent(in) :: wa3(*)
+        real(wp), intent(in) :: wa4(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp) :: ti5, ti4, tr2, tr3, cr2, cr3, ci5
+        real(wp) :: ci4, ti2, ti3, tr5, tr4, ci2, ci3, cr5, cr4, dr3, dr4, di3
+        real(wp) :: di4, dr5, dr2, di5, di2
+        real(wp), parameter :: tr11 = (SQRT_5 - ONE)/4 ! 0.309016994374947
+        real(wp), parameter :: ti11 = sqrt((FIVE + SQRT_5)/2)/2 ! 0.951056516295154
+        real(wp), parameter :: tr12 = (-ONE - SQRT_5)/4 ! -.809016994374947
+        real(wp), parameter :: ti12 = sqrt(FIVE/(TWO * (FIVE + SQRT_5)) ) ! 0.587785252292473
+
+
+
+        do k = 1, l1
+            ti5 = cc(1, 3, k) + cc(1, 3, k)
+            ti4 = cc(1, 5, k) + cc(1, 5, k)
+            tr2 = cc(ido, 2, k) + cc(ido, 2, k)
+            tr3 = cc(ido, 4, k) + cc(ido, 4, k)
+            ch(1, k, 1) = cc(1, 1, k) + tr2 + tr3
+            cr2 = cc(1, 1, k) + tr11*tr2 + tr12*tr3
+            cr3 = cc(1, 1, k) + tr12*tr2 + tr11*tr3
+            ci5 = ti11*ti5 + ti12*ti4
+            ci4 = ti12*ti5 - ti11*ti4
+            ch(1, k, 2) = cr2 - ci5
+            ch(1, k, 3) = cr3 - ci4
+            ch(1, k, 4) = cr3 + ci4
+            ch(1, k, 5) = cr2 + ci5
+        end do
+
+        if(ido /= 1) then
+            idp2 = ido + 2
+            do k = 1, l1
+                do i = 3, ido, 2
+                    ic = idp2 - i
+                    ti5 = cc(i, 3, k) + cc(ic, 2, k)
+                    ti2 = cc(i, 3, k) - cc(ic, 2, k)
+                    ti4 = cc(i, 5, k) + cc(ic, 4, k)
+                    ti3 = cc(i, 5, k) - cc(ic, 4, k)
+                    tr5 = cc(i-1, 3, k) - cc(ic-1, 2, k)
+                    tr2 = cc(i-1, 3, k) + cc(ic-1, 2, k)
+                    tr4 = cc(i-1, 5, k) - cc(ic-1, 4, k)
+                    tr3 = cc(i-1, 5, k) + cc(ic-1, 4, k)
+                    ch(i-1, k, 1) = cc(i-1, 1, k) + tr2 + tr3
+                    ch(i, k, 1) = cc(i, 1, k) + ti2 + ti3
+                    cr2 = cc(i-1, 1, k) + tr11*tr2 + tr12*tr3
+                    ci2 = cc(i, 1, k) + tr11*ti2 + tr12*ti3
+                    cr3 = cc(i-1, 1, k) + tr12*tr2 + tr11*tr3
+                    ci3 = cc(i, 1, k) + tr12*ti2 + tr11*ti3
+                    cr5 = ti11*tr5 + ti12*tr4
+                    ci5 = ti11*ti5 + ti12*ti4
+                    cr4 = ti12*tr5 - ti11*tr4
+                    ci4 = ti12*ti5 - ti11*ti4
+                    dr3 = cr3 - ci4
+                    dr4 = cr3 + ci4
+                    di3 = ci3 + cr4
+                    di4 = ci3 - cr4
+                    dr5 = cr2 + ci5
+                    dr2 = cr2 - ci5
+                    di5 = ci2 - cr5
+                    di2 = ci2 + cr5
+                    ch(i-1, k, 2) = wa1(i-2)*dr2 - wa1(i-1)*di2
+                    ch(i, k, 2) = wa1(i-2)*di2 + wa1(i-1)*dr2
+                    ch(i-1, k, 3) = wa2(i-2)*dr3 - wa2(i-1)*di3
+                    ch(i, k, 3) = wa2(i-2)*di3 + wa2(i-1)*dr3
+                    ch(i-1, k, 4) = wa3(i-2)*dr4 - wa3(i-1)*di4
+                    ch(i, k, 4) = wa3(i-2)*di4 + wa3(i-1)*dr4
+                    ch(i-1, k, 5) = wa4(i-2)*dr5 - wa4(i-1)*di5
+                    ch(i, k, 5) = wa4(i-2)*di5 + wa4(i-1)*dr5
+                end do
+            end do
+        end if
+
+    end subroutine real_backward_pass_5
+
+    subroutine real_backward_pass_n(ido, iip, l1, idl1, cc, c1, c2, ch, ch2, wa)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: iip
+        integer(ip), intent(in) :: l1
+        integer(ip), intent(in) :: idl1
+        real(wp), intent(in) :: cc(ido, iip, l1)
+        real(wp), intent(inout)  :: c1(ido, l1, iip)
+        real(wp), intent(inout)  :: c2(idl1, iip)
+        real(wp), intent(inout)  :: ch(ido, l1, iip)
+        real(wp), intent(inout)  :: ch2(idl1, iip)
+        real(wp), intent(in) :: wa(*)
+
+        ! Local variables
+
+        integer:: idp2, nbd, iipp2, iipph, k, i, j, jc, j2, l, lc, is, idij
+        real(wp) :: arg, dcp, dsp, ar1, ai1, ar1h, dc2, ds2, ar2, ai2, ar2h
+
+
+        arg = TWO_PI/iip
+        dcp = cos(arg)
+        dsp = sin(arg)
+        idp2 = ido + 2
+        nbd =(ido - 1)/2
+        iipp2 = iip + 2
+        iipph = (iip + 1)/2
+
+        ch(:,:, 1) = cc(:, 1,:)
+
+        do j = 2, iipph
+            jc = iipp2 - j
+            j2 = j + j
+            ch(1,:, j) = cc(ido, j2-2,:) + cc(ido, j2-2,:)
+            ch(1,:, jc) = cc(1, j2-1,:) + cc(1, j2-1,:)
+        end do
+
+        if(ido /= 1) then
+            if (l1 <= nbd) then
+                do j = 2, iipph
+                    jc = iipp2 - j
+                    ch(2:ido-1:2,:, j) = cc(2:ido-1:2, 2*j-1,:) + cc(idp2-4: &
+                        idp2-1-ido:(-2), 2*j-2,:)
+                    ch(2:ido-1:2,:, jc) = cc(2:ido-1:2, 2*j-1,:) - cc(idp2-4: &
+                        idp2-1-ido:(-2), 2*j-2,:)
+                    ch(3:ido:2,:, j) = cc(3:ido:2, 2*j-1,:) - cc(idp2-3:idp2- &
+                        ido:(-2), 2*j-2,:)
+                    ch(3:ido:2,:, jc) = cc(3:ido:2, 2*j-1,:) + cc(idp2-3:idp2- &
+                        ido:(-2), 2*j-2,:)
+                end do
+            else
+                do j = 2, iipph
+                    jc = iipp2 - j
+                    ch(2:ido-1:2,:, j) = cc(2:ido-1:2, 2*j-1,:) + cc(idp2-4: &
+                        idp2-1-ido:(-2), 2*j-2,:)
+                    ch(2:ido-1:2,:, jc) = cc(2:ido-1:2, 2*j-1,:) - cc(idp2-4: &
+                        idp2-1-ido:(-2), 2*j-2,:)
+                    ch(3:ido:2,:, j) = cc(3:ido:2, 2*j-1,:) - cc(idp2-3:idp2- &
+                        ido:(-2), 2*j-2,:)
+                    ch(3:ido:2,:, jc) = cc(3:ido:2, 2*j-1,:) + cc(idp2-3:idp2- &
+                        ido:(-2), 2*j-2,:)
+                end do
+            end if
+        end if
+
+        ar1 = ONE
+        ai1 = ZERO
+
+        do l = 2, iipph
+            lc = iipp2 - l
+            ar1h = dcp*ar1 - dsp*ai1
+            ai1 = dcp*ai1 + dsp*ar1
+            ar1 = ar1h
+            c2(:, l) = ch2(:, 1) + ar1*ch2(:, 2)
+            c2(:, lc) = ai1*ch2(:, iip)
+            dc2 = ar1
+            ds2 = ai1
+            ar2 = ar1
+            ai2 = ai1
+            do j = 3, iipph
+                jc = iipp2 - j
+                ar2h = dc2*ar2 - ds2*ai2
+                ai2 = dc2*ai2 + ds2*ar2
+                ar2 = ar2h
+                c2(:, l) = c2(:, l) + ar2*ch2(:, j)
+                c2(:, lc) = c2(:, lc) + ai2*ch2(:, jc)
+            end do
+        end do
+
+        do j = 2, iipph
+            ch2(:, 1) = ch2(:, 1) + ch2(:, j)
+        end do
+
+        do j = 2, iipph
+            jc = iipp2 - j
+            ch(1,:, j) = c1(1,:, j) - c1(1,:, jc)
+            ch(1,:, jc) = c1(1,:, j) + c1(1,:, jc)
+        end do
+
+        if(ido /= 1) then
+            if (l1 <= nbd) then
+                do j = 2, iipph
+                    jc = iipp2 - j
+                    ch(2:ido-1:2,:, j) = c1(2:ido-1:2,:, j) - c1(3:ido:2,:, jc)
+                    ch(2:ido-1:2,:, jc) = c1(2:ido-1:2,:, j) + c1(3:ido:2,:, jc)
+                    ch(3:ido:2,:, j) = c1(3:ido:2,:, j) + c1(2:ido-1:2,:, jc)
+                    ch(3:ido:2,:, jc) = c1(3:ido:2,:, j) - c1(2:ido-1:2,:, jc)
+                end do
+            else
+                do j = 2, iipph
+                    jc = iipp2 - j
+                    ch(2:ido-1:2,:, j) = c1(2:ido-1:2,:, j) - c1(3:ido:2,:, jc)
+                    ch(2:ido-1:2,:, jc) = c1(2:ido-1:2,:, j) + c1(3:ido:2,:, jc)
+                    ch(3:ido:2,:, j) = c1(3:ido:2,:, j) + c1(2:ido-1:2,:, jc)
+                    ch(3:ido:2,:, jc) = c1(3:ido:2,:, j) - c1(2:ido-1:2,:, jc)
+                end do
+            end if
+        end if
+
+        if(ido /= 1) then
+            c2(:, 1) = ch2(:, 1)
+            c1(1,:, 2:iip) = ch(1,:, 2:iip)
+            if (nbd <= l1) then
+                is = -ido
+                do j = 2, iip
+                    is = is + ido
+                    idij = is
+                    do i = 3, ido, 2
+                        idij = idij + 2
+                        c1(i-1,:, j) = wa(idij-1)*ch(i-1,:, j) - wa(idij)*ch(i,:, j)
+                        c1(i,:, j) = wa(idij-1)*ch(i,:, j) + wa(idij)*ch(i-1,:, j)
+                    end do
+                end do
+            else
+                is = -ido
+                do j = 2, iip
+                    is = is + ido
+                    do k = 1, l1
+                        idij = is
+                        c1(2:ido-1:2, k, j) = wa(idij+1:ido-2+idij:2)*ch(2:ido-1:2, &
+                            k, j) - wa(idij+2:ido-1+idij:2)*ch(3:ido:2, k, j)
+                        c1(3:ido:2, k, j) = wa(idij+1:ido-2+idij:2)*ch(3:ido:2, k, j) &
+                            + wa(idij+2:ido-1+idij:2)*ch(2:ido-1:2, k, j)
+                    end do
+                end do
+            end if
+        end if
+
+    end subroutine real_backward_pass_n
+
+    subroutine rfftf(n, r, wsave)
+
+        ! Dummy arguments
+
+        integer(ip) :: n
+        real(wp) :: r(*)
+        real(wp) :: wsave(*)
+
+
+        if (n /= 1) then
+            call real_forward_lower_routine(n, r, wsave, wsave(n+1), wsave(2*n+1))
+        end if
+
+    end subroutine rfftf
+
+    subroutine real_forward_lower_routine(n, c, ch, wa, ifac)
+
+        ! Dummy arguments
+
+        integer(ip),  intent(in) :: n
+        real(wp), intent(in) :: ifac(*)
+        real(wp)              :: c(*)
+        real(wp)              :: ch(*)
+        real(wp)              :: wa(*)
+
+        ! Local variables
+
+        integer(ip) :: nf, na, l2, iw, k1, kh
+        integer(ip) :: iip, l1, ido, idl1, ix2, ix3, ix4
+
+
+        nf = int(ifac(2), kind=ip)
+        na = 1
+        l2 = n
+        iw = n
+
+        do k1 = 1, nf
+            kh = nf - k1
+            iip = int(ifac(kh+3), kind=ip)
+            l1 = l2/iip
+            ido = n/l2
+            idl1 = ido*l1
+            iw = iw - (iip - 1)*ido
+            na = 1 - na
+
+            select case (iip)
+                case (2)
+                    if (na == 0) then
+                        call real_forward_pass_2(ido, l1, c, ch, wa(iw))
+                    else
+                        call real_forward_pass_2(ido, l1, ch, c, wa(iw))
+                    end if
+                case (3)
+                    ix2 = iw + ido
+                    if (na == 0) then
+                        call real_forward_pass_3(ido, l1, c, ch, wa(iw), wa(ix2))
+                    else
+                        call real_forward_pass_3(ido, l1, ch, c, wa(iw), wa(ix2))
+                    end if
+                case (4)
+                    ix2 = iw + ido
+                    ix3 = ix2 + ido
+                    if (na == 0) then
+                        call real_forward_pass_4(ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3))
+                    else
+                        call real_forward_pass_4(ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3))
+                    end if
+                case (5)
+                    ix2 = iw + ido
+                    ix3 = ix2 + ido
+                    ix4 = ix3 + ido
+                    if (na == 0) then
+                        call real_forward_pass_5(ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4))
+                    else
+                        call real_forward_pass_5(ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4))
+                    end if
+                case default
+                    if(ido == 1) then
+                        na = 1 - na
+                    end if
+                    if (na == 0) then
+                        call real_forward_pass_n(ido, iip, l1, idl1, c, c, c, ch, ch, wa(iw))
+                        na = 1
+                    else
+                        call real_forward_pass_n(ido, iip, l1, idl1, ch, ch, ch, c, c, wa(iw))
+                        na = 0
+                    end if
+            end select
+            l2 = l1
+        end do
+
+        if (na /= 1) c(:n) = ch(:n)
+
+    end subroutine real_forward_lower_routine
+
+    pure subroutine real_forward_pass_2(ido, l1, cc, ch, wa1)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, l1, 2)
+        real(wp), intent(out) :: ch(ido, 2, l1)
+        real(wp), intent(in) :: wa1(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp) :: tr2, ti2
+
+
+        ch(1, 1,:) = cc(1,:, 1) + cc(1,:, 2)
+        ch(ido, 2,:) = cc(1,:, 1) - cc(1,:, 2)
+
+        if (ido >= 2) then
+            if (ido /= 2) then
+                idp2 = ido + 2
+                do k = 1, l1
+                    do i = 3, ido, 2
+                        ic = idp2 - i
+                        tr2 = wa1(i-2)*cc(i-1, k, 2) + wa1(i-1)*cc(i, k, 2)
+                        ti2 = wa1(i-2)*cc(i, k, 2) - wa1(i-1)*cc(i-1, k, 2)
+                        ch(i, 1, k) = cc(i, k, 1) + ti2
+                        ch(ic, 2, k) = ti2 - cc(i, k, 1)
+                        ch(i-1, 1, k) = cc(i-1, k, 1) + tr2
+                        ch(ic-1, 2, k) = cc(i-1, k, 1) - tr2
+                    end do
+                end do
+                if (mod(ido, 2) == 1) then
+                    return
+                end if
+            end if
+            ch(1, 2,:) = -cc(ido,:, 2)
+            ch(ido, 1,:) = cc(ido,:, 1)
+        end if
+
+    end subroutine real_forward_pass_2
+
+    pure subroutine real_forward_pass_3(ido, l1, cc, ch, wa1, wa2)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in) :: ido
+        integer(ip), intent(in) :: l1
+        real(wp), intent(in) :: cc(ido, l1, 3)
+        real(wp), intent(out) :: ch(ido, 3, l1)
+        real(wp), intent(in) :: wa1(*)
+        real(wp), intent(in) :: wa2(*)
+
+        ! Local variables
+
+        integer(ip)         :: k, idp2, i, ic
+        real(wp), parameter :: taur = -HALF
+        real(wp), parameter :: taui = sqrt(THREE)/TWO ! 0.866025403784439
+        real(wp)            :: cr2, dr2, di2, dr3, di3, ci2, tr2, ti2, tr3, ti3
+
+
+        do k = 1, l1
+            cr2 = cc(1, k, 2) + cc(1, k, 3)
+            ch(1, 1, k) = cc(1, k, 1) + cr2
+            ch(1, 3, k) = taui*(cc(1, k, 3)-cc(1, k, 2))
+            ch(ido, 2, k) = cc(1, k, 1) + taur*cr2
+        end do
+
+        if(ido /= 1) then
+            idp2 = ido + 2
+            do k = 1, l1
+                do i = 3, ido, 2
+                    ic = idp2 - i
+                    dr2 = wa1(i-2)*cc(i-1, k, 2) + wa1(i-1)*cc(i, k, 2)
+                    di2 = wa1(i-2)*cc(i, k, 2) - wa1(i-1)*cc(i-1, k, 2)
+                    dr3 = wa2(i-2)*cc(i-1, k, 3) + wa2(i-1)*cc(i, k, 3)
+                    di3 = wa2(i-2)*cc(i, k, 3) - wa2(i-1)*cc(i-1, k, 3)
+                    cr2 = dr2 + dr3
+                    ci2 = di2 + di3
+                    ch(i-1, 1, k) = cc(i-1, k, 1) + cr2
+                    ch(i, 1, k) = cc(i, k, 1) + ci2
+                    tr2 = cc(i-1, k, 1) + taur*cr2
+                    ti2 = cc(i, k, 1) + taur*ci2
+                    tr3 = taui*(di2 - di3)
+                    ti3 = taui*(dr3 - dr2)
+                    ch(i-1, 3, k) = tr2 + tr3
+                    ch(ic-1, 2, k) = tr2 - tr3
+                    ch(i, 3, k) = ti2 + ti3
+                    ch(ic, 2, k) = ti3 - ti2
+                end do
+            end do
+        end if
+
+    end subroutine real_forward_pass_3
+
+    subroutine real_forward_pass_4(ido, l1, cc, ch, wa1, wa2, wa3)
+
+        ! Dummy arguments
+
+        integer(ip),  intent(in)  :: ido
+        integer(ip),  intent(in)  :: l1
+        real(wp), intent(in)  :: cc(ido, l1, 4)
+        real(wp), intent(out) :: ch(ido, 4, l1)
+        real(wp), intent(in)  :: wa1(*)
+        real(wp), intent(in)  :: wa2(*)
+        real(wp), intent(in)  :: wa3(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp) :: tr1, tr2, cr2, ci2, cr3, ci3
+        real(wp) :: cr4, ci4, tr4, ti1
+        real(wp) :: ti4, ti2, ti3, tr3
+        real(wp), parameter :: ONE_OVER_SQRT_2 = ONE/SQRT_2
+
+
+        do k = 1, l1
+            tr1 = cc(1, k, 2) + cc(1, k, 4)
+            tr2 = cc(1, k, 1) + cc(1, k, 3)
+            ch(1, 1, k) = tr1 + tr2
+            ch(ido, 4, k) = tr2 - tr1
+            ch(ido, 2, k) = cc(1, k, 1) - cc(1, k, 3)
+            ch(1, 3, k) = cc(1, k, 4) - cc(1, k, 2)
+        end do
+
+        if (ido >= 2) then
+            if (ido /= 2) then
+                idp2 = ido + 2
+                do k = 1, l1
+                    do i = 3, ido, 2
+                        ic = idp2 - i
+                        cr2 = wa1(i-2)*cc(i-1, k, 2) + wa1(i-1)*cc(i, k, 2)
+                        ci2 = wa1(i-2)*cc(i, k, 2) - wa1(i-1)*cc(i-1, k, 2)
+                        cr3 = wa2(i-2)*cc(i-1, k, 3) + wa2(i-1)*cc(i, k, 3)
+                        ci3 = wa2(i-2)*cc(i, k, 3) - wa2(i-1)*cc(i-1, k, 3)
+                        cr4 = wa3(i-2)*cc(i-1, k, 4) + wa3(i-1)*cc(i, k, 4)
+                        ci4 = wa3(i-2)*cc(i, k, 4) - wa3(i-1)*cc(i-1, k, 4)
+                        tr1 = cr2 + cr4
+                        tr4 = cr4 - cr2
+                        ti1 = ci2 + ci4
+                        ti4 = ci2 - ci4
+                        ti2 = cc(i, k, 1) + ci3
+                        ti3 = cc(i, k, 1) - ci3
+                        tr2 = cc(i-1, k, 1) + cr3
+                        tr3 = cc(i-1, k, 1) - cr3
+                        ch(i-1, 1, k) = tr1 + tr2
+                        ch(ic-1, 4, k) = tr2 - tr1
+                        ch(i, 1, k) = ti1 + ti2
+                        ch(ic, 4, k) = ti1 - ti2
+                        ch(i-1, 3, k) = ti4 + tr3
+                        ch(ic-1, 2, k) = tr3 - ti4
+                        ch(i, 3, k) = tr4 + ti3
+                        ch(ic, 2, k) = tr4 - ti3
+                    end do
+                end do
+                if (mod(ido, 2) == 1) then
+                    return
+                end if
+            end if
+            do k = 1, l1
+                ti1 = -ONE_OVER_SQRT_2*(cc(ido, k, 2)+cc(ido, k, 4))
+                tr1 = ONE_OVER_SQRT_2*(cc(ido, k, 2)-cc(ido, k, 4))
+                ch(ido, 1, k) = tr1 + cc(ido, k, 1)
+                ch(ido, 3, k) = cc(ido, k, 1) - tr1
+                ch(1, 2, k) = ti1 - cc(ido, k, 3)
+                ch(1, 4, k) = ti1 + cc(ido, k, 3)
+            end do
+        end if
+
+    end subroutine real_forward_pass_4
+
+    subroutine real_forward_pass_5(ido, l1, cc, ch, wa1, wa2, wa3, wa4)
+
+        ! Dummy arguments
+
+        integer(ip),  intent(in)  :: ido
+        integer(ip),  intent(in)  :: l1
+        real(wp), intent(in)  :: cc(ido, l1, 5)
+        real(wp), intent(out) :: ch(ido, 5, l1)
+        real(wp), intent(in)  :: wa1(*)
+        real(wp), intent(in)  :: wa2(*)
+        real(wp), intent(in)  :: wa3(*)
+        real(wp), intent(in)  :: wa4(*)
+
+        ! Local variables
+
+        integer(ip) :: k, idp2, i, ic
+        real(wp) :: cr2, ci5, cr3, ci4, dr2, di2, dr3
+        real(wp) :: di3, dr4, di4, dr5, di5, cr5, ci2, cr4, ci3, tr2, ti2, tr3
+        real(wp) :: ti3, tr5, ti5, tr4, ti4
+        real(wp), parameter :: tr11 = (SQRT_5 - ONE)/4
+        real(wp), parameter :: ti11 = sqrt((FIVE + SQRT_5)/2)/2
+        real(wp), parameter :: tr12 = (-ONE - SQRT_5)/4
+        real(wp), parameter :: ti12 = sqrt(FIVE/(TWO * (FIVE + SQRT_5)))
+
+
+        do k = 1, l1
+            cr2 = cc(1, k, 5) + cc(1, k, 2)
+            ci5 = cc(1, k, 5) - cc(1, k, 2)
+            cr3 = cc(1, k, 4) + cc(1, k, 3)
+            ci4 = cc(1, k, 4) - cc(1, k, 3)
+            ch(1, 1, k) = cc(1, k, 1) + cr2 + cr3
+            ch(ido, 2, k) = cc(1, k, 1) + tr11*cr2 + tr12*cr3
+            ch(1, 3, k) = ti11*ci5 + ti12*ci4
+            ch(ido, 4, k) = cc(1, k, 1) + tr12*cr2 + tr11*cr3
+            ch(1, 5, k) = ti12*ci5 - ti11*ci4
+        end do
+
+        if(ido /= 1) then
+            idp2 = ido + 2
+            do k = 1, l1
+                do i = 3, ido, 2
+                    ic = idp2 - i
+                    dr2 = wa1(i-2)*cc(i-1, k, 2) + wa1(i-1)*cc(i, k, 2)
+                    di2 = wa1(i-2)*cc(i, k, 2) - wa1(i-1)*cc(i-1, k, 2)
+                    dr3 = wa2(i-2)*cc(i-1, k, 3) + wa2(i-1)*cc(i, k, 3)
+                    di3 = wa2(i-2)*cc(i, k, 3) - wa2(i-1)*cc(i-1, k, 3)
+                    dr4 = wa3(i-2)*cc(i-1, k, 4) + wa3(i-1)*cc(i, k, 4)
+                    di4 = wa3(i-2)*cc(i, k, 4) - wa3(i-1)*cc(i-1, k, 4)
+                    dr5 = wa4(i-2)*cc(i-1, k, 5) + wa4(i-1)*cc(i, k, 5)
+                    di5 = wa4(i-2)*cc(i, k, 5) - wa4(i-1)*cc(i-1, k, 5)
+                    cr2 = dr2 + dr5
+                    ci5 = dr5 - dr2
+                    cr5 = di2 - di5
+                    ci2 = di2 + di5
+                    cr3 = dr3 + dr4
+                    ci4 = dr4 - dr3
+                    cr4 = di3 - di4
+                    ci3 = di3 + di4
+                    ch(i-1, 1, k) = cc(i-1, k, 1) + cr2 + cr3
+                    ch(i, 1, k) = cc(i, k, 1) + ci2 + ci3
+                    tr2 = cc(i-1, k, 1) + tr11*cr2 + tr12*cr3
+                    ti2 = cc(i, k, 1) + tr11*ci2 + tr12*ci3
+                    tr3 = cc(i-1, k, 1) + tr12*cr2 + tr11*cr3
+                    ti3 = cc(i, k, 1) + tr12*ci2 + tr11*ci3
+                    tr5 = ti11*cr5 + ti12*cr4
+                    ti5 = ti11*ci5 + ti12*ci4
+                    tr4 = ti12*cr5 - ti11*cr4
+                    ti4 = ti12*ci5 - ti11*ci4
+                    ch(i-1, 3, k) = tr2 + tr5
+                    ch(ic-1, 2, k) = tr2 - tr5
+                    ch(i, 3, k) = ti2 + ti5
+                    ch(ic, 2, k) = ti5 - ti2
+                    ch(i-1, 5, k) = tr3 + tr4
+                    ch(ic-1, 4, k) = tr3 - tr4
+                    ch(i, 5, k) = ti3 + ti4
+                    ch(ic, 4, k) = ti4 - ti3
+                end do
+            end do
+        end if
+
+    end subroutine real_forward_pass_5
+
+    subroutine real_forward_pass_n(ido, iip, l1, idl1, cc, c1, c2, ch, ch2, wa)
+
+        ! Dummy arguments
+
+        integer(ip), intent(in)      :: ido
+        integer(ip), intent(in)      :: iip
+        integer(ip), intent(in)      :: l1
+        integer(ip), intent(in)      :: idl1
+        real(wp), intent(out)    :: cc(ido, iip, l1)
+        real(wp), intent(inout)  :: c1(ido, l1, iip)
+        real(wp), intent(inout)  :: c2(idl1, iip)
+        real(wp), intent(inout)  :: ch(ido, l1, iip)
+        real(wp), intent(inout)  :: ch2(idl1, iip)
+        real(wp), intent(in)     :: wa(*)
+
+        ! Local variables
+
+        integer(ip)         :: iipph, iipp2, idp2, nbd, j
+        integer(ip)         :: k, is, idij, i, jc, l, lc
+        real(wp)            :: arg, dcp, dsp, ar1, ai1
+        real(wp)            :: ar1h, dc2, ds2, ar2, ai2, ar2h
+
+
+        arg = TWO_PI/iip
+        dcp = cos(arg)
+        dsp = sin(arg)
+        iipph = (iip + 1)/2
+        iipp2 = iip + 2
+        idp2 = ido + 2
+        nbd =(ido - 1)/2
+
+        block_construct: block
+            if (ido /= 1) then
+                ch2(:, 1) = c2(:, 1)
+                ch(1,:, 2:iip) = c1(1,:, 2:iip)
+                if (nbd <= l1) then
+                    is = -ido
+                    do j = 2, iip
+                        is = is + ido
+                        idij = is
+                        do i = 3, ido, 2
+                            idij = idij + 2
+                            ch(i-1,:, j)=wa(idij-1)*c1(i-1,:, j)+wa(idij)*c1(i,:, j)
+                            ch(i,:, j)=wa(idij-1)*c1(i,:, j)-wa(idij)*c1(i-1,:, j)
+                        end do
+                    end do
+                else
+                    is = -ido
+                    do j = 2, iip
+                        is = is + ido
+                        do k = 1, l1
+                            idij = is
+                            ch(2:ido-1:2, k, j) = wa(idij+1:ido-2+idij:2)*c1(2:ido-1 &
+                                :2, k, j) + wa(idij+2:ido-1+idij:2)*c1(3:ido:2, k, j)
+                            ch(3:ido:2, k, j) = wa(idij+1:ido-2+idij:2)*c1(3:ido:2, k &
+                                , j) - wa(idij+2:ido-1+idij:2)*c1(2:ido-1:2, k, j)
+                        end do
+                    end do
+                end if
+                if (l1 <= nbd) then
+                    do j = 2, iipph
+                        jc = iipp2 - j
+                        c1(2:ido-1:2,:, j)=ch(2:ido-1:2,:, j)+ch(2:ido-1:2,:, jc)
+                        c1(2:ido-1:2,:, jc) = ch(3:ido:2,:, j) - ch(3:ido:2,:, jc)
+                        c1(3:ido:2,:, j) = ch(3:ido:2,:, j) + ch(3:ido:2,:, jc)
+                        c1(3:ido:2,:, jc) = ch(2:ido-1:2,:, jc) - ch(2:ido-1:2,:, j)
+                    end do
+                    exit block_construct
+                end if
+                do j = 2, iipph
+                    jc = iipp2 - j
+                    c1(2:ido-1:2,:, j) = ch(2:ido-1:2,:, j) + ch(2:ido-1:2,:, jc)
+                    c1(2:ido-1:2,:, jc) = ch(3:ido:2,:, j) - ch(3:ido:2,:, jc)
+                    c1(3:ido:2,:, j) = ch(3:ido:2,:, j) + ch(3:ido:2,:, jc)
+                    c1(3:ido:2,:, jc) = ch(2:ido-1:2,:, jc) - ch(2:ido-1:2,:, j)
+                end do
+                exit block_construct
+            end if
+            c2(:, 1) = ch2(:, 1)
+        end block block_construct
+
+        do j = 2, iipph
+            jc = iipp2 - j
+            c1(1,:, j) = ch(1,:, j) + ch(1,:, jc)
+            c1(1,:, jc) = ch(1,:, jc) - ch(1,:, j)
+        end do
+
+        ar1 = ONE
+        ai1 = ZERO
+        do l = 2, iipph
+            lc = iipp2 - l
+            ar1h = dcp*ar1 - dsp*ai1
+            ai1 = dcp*ai1 + dsp*ar1
+            ar1 = ar1h
+            ch2(:, l) = c2(:, 1) + ar1*c2(:, 2)
+            ch2(:, lc) = ai1*c2(:, iip)
+            dc2 = ar1
+            ds2 = ai1
+            ar2 = ar1
+            ai2 = ai1
+            do j = 3, iipph
+                jc = iipp2 - j
+                ar2h = dc2*ar2 - ds2*ai2
+                ai2 = dc2*ai2 + ds2*ar2
+                ar2 = ar2h
+                ch2(:, l) = ch2(:, l) + ar2*c2(:, j)
+                ch2(:, lc) = ch2(:, lc) + ai2*c2(:, jc)
+            end do
+        end do
+
+        do j = 2, iipph
+            ch2(:, 1) = ch2(:, 1) + c2(:, j)
+        end do
+
+        cc(:, 1,:) = ch(:,:, 1)
+        cc(ido, 2:(iipph-1)*2:2,:) = transpose(ch(1,:, 2:iipph))
+        cc(1, 3:iipph*2-1:2,:) = transpose(ch(1,:, iipp2-2:iipp2-iipph:(-1)))
+
+        if(ido /= 1) then
+            if (l1 <= nbd) then
+                cc(2:ido-1:2, 3:iipph*2-1:2,:) = &
+                    reshape( &
+                    source = ch(2:ido-1:2,:,2:iipph)+ch(2:ido-1:2,:, iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(idp2-4:idp2-1-ido:(-2), 2:(iipph-1)*2:2,:) = &
+                    reshape( &
+                    source = ch(2:ido-1:2,:, 2:iipph)-ch(2:ido-1:2,:, iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(3:ido:2, 3:iipph*2-1:2,:) = &
+                    reshape(&
+                    source = ch(3:ido:2,:,2:iipph)+ch(3:ido:2,:,iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(idp2-3:idp2-ido:(-2), 2:(iipph-1)*2:2,:) = &
+                    reshape(&
+                    source = ch(3:ido:2,:, iipp2-2:iipp2-iipph:(-1))-ch(3:ido:2,:, 2:iipph), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+            else
+                cc(2:ido-1:2, 3:iipph*2-1:2,:) = &
+                    reshape( &
+                    source = ch(2:ido-1:2,:, 2:iipph)+ch(2:ido-1:2,:, iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(idp2-4:idp2-1-ido:(-2), 2:(iipph-1)*2:2,:) = &
+                    reshape( &
+                    source = ch(2:ido-1:2,:, 2:iipph)-ch(2:ido-1:2,:, iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(3:ido:2, 3:iipph*2-1:2,:) = &
+                    reshape( &
+                    source = ch(3:ido:2,:, 2:iipph)+ch(3:ido:2,:, iipp2-2:iipp2-iipph:(-1)), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+                cc(idp2-3:idp2-ido:(-2), 2:(iipph-1)*2:2,:) = &
+                    reshape( &
+                    source = ch(3:ido:2,:,iipp2-2:iipp2-iipph:(-1))-ch(3:ido:2,:, 2:iipph), &
+                    shape = [(ido-1)/2, iipph-1, l1], &
+                    order = [1, 3, 2] &
+                    )
+            end if
+        end if
+
+    end subroutine real_forward_pass_n
+
+end module type_PeriodicFastFourierTransform