MODULE mo_specan

  ! This module provides routines for spectral analysis
  ! using routines from fftpack http://orion.math.iastate.edu/burkardt/f_src/fftpack/fftpack.html

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2013 Philipp Bosecker
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind,      ONLY: i4, sp, spc, dp, dpc
  USE mo_constants, ONLY: PI_sp, PI_dp
  USE mo_nelmin,    ONLY: nelminrange

  IMPLICIT NONE

  PUBLIC :: cost            ! Cost function for fitting linear reservoir model
  PUBLIC :: linres          ! Fitting linear reservoir model
  PUBLIC :: periodogram     ! Periodogram of given dataset using FFT
  PUBLIC :: setmeas         ! Set measurement as module variable

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

  !     NAME
  !         cost

  !     PURPOSE
  !         Define objective function to fit linear reservoir model linres to data.

  !     CALLING SEQUENCE
  !         func = cost(para)

  !     INTENT(IN)
  !         real(sp/dp) :: para(:)        parameter of function

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         see test example test_mo_specan

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written, December 2013, Philipp Bosecker

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

  INTERFACE cost
     MODULE PROCEDURE cost_sp, cost_dp
  END INTERFACE cost

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

  !     NAME
  !         linres

  !     PURPOSE
  !         Fitting a linear reservoir model f dependent on the frequency w
  !                  f(w)=1/(a(1+tc^2w^2))
  !         introduced by Gelhar et. al (1974) to the double logarithmic periodogram of a time series.
  !         The time series is for example groundwater fluctuations.
  !         The periodogram can be determined using the subroutine periodogram.
  !         The best fitting parameters a and tc are returned.
  !         In the linear reservoir model a is a discharge constant and
  !         tc is the characteristic respond time.

  !     CALLING SEQUENCE
  !         call linres(data,bestpara,a_min,a_max,tc_min,tc_max,initial_a,initial_tc)

  !     INTENT(IN)
  !         real(sp/dp) :: data(:)        Time series
  !         real(sp/dp) :: a_min          minimum of first parameter
  !         real(sp/dp) :: a_max          maximum of first parameter
  !         real(sp/dp) :: tc_min         minimum of second parameter
  !         real(sp/dp) :: tc_max         maximum of second parameter
  !         real(sp/dp) :: initial_a      first initial parameter
  !         real(sp/dp) :: initial_tc     second initial parameter

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp(dp) :: bestpara(2)    best fitting parameter a and tc found for linear reservoir model

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         see test example test_mo_specan

  !     LITERATURE
  !       Lynn W. Gelhar and John L. Wilson,
  !           Ground-Water Quality Modeling,
  !           Ground Water, 1974

  !     HISTORY
  !         Written, December 2013, Philipp Bosecker

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

  INTERFACE linres
     MODULE PROCEDURE linres_sp, linres_dp
  END INTERFACE linres

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

  !     NAME
  !         periodogram

  !     PURPOSE
  !         Computes the periodogram of given dataset using FFT. The periodogram
  !         is calculated as the square of the absolut value of the discrete complex
  !         Fourier transformation. The output periodogram has the size of N/2.

  !     CALLING SEQUENCE
  !         call periodogram(data,output)

  !     INTENT(IN)
  !         real(sp/dp) :: data(:)        Time series

  !     INTENT(INOUT)
  !         NONE

  !     INTENT(OUT)
  !         real(sp/dp) :: output(:,2)    frequency, power

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         see test example test_mo_specan

  !     LITERATURE
  !       P.N. Swarztrauber,
  !           Vectorizing the FFTs, in Parallel Computations (G. Rodrigue, ed.),
  !           Academic Press, 1982, pp. 51--83

  !     HISTORY
  !         Written, December 2013, Philipp Bosecker

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

  INTERFACE periodogram
     MODULE PROCEDURE periodogram_sp, periodogram_dp
  END INTERFACE periodogram

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

  !     NAME
  !         setmeas

  !     PURPOSE
  !         Read in data/measurements and store them as global module variable meas.
  !         Global module variable is needed since optimization only allows for a single argument
  !         (which is parameter set) of the objective function.

  !     CALLING SEQUENCE
  !         call setmeas(data)

  !     INTENT(IN)
  !         real(sp/dp) :: data(:)        data/measurements

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         see test example test_mo_specan

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written, December 2013, Philipp Bosecker

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

  INTERFACE setmeas
     MODULE PROCEDURE setmeas_dp, setmeas_sp
  END INTERFACE setmeas

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

  PRIVATE

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

  REAL(dp), DIMENSION(:), ALLOCATABLE :: meas_dp      ! data/measurement
  REAL(sp), DIMENSION(:), ALLOCATABLE :: meas_sp      ! data/measurement

  !**************************************************
  !
  ! Changes that have been done in FFTPACK routines:
  !
  ! - Declaration of data type
  ! - single and double precision versions
  ! - fixed that wrong data types were overgiven
  !
  !**************************************************

  ! Private routines, mostly from fftpack
  INTERFACE cfftf
     MODULE PROCEDURE cfftf_sp, cfftf_dp
  END INTERFACE cfftf
  INTERFACE cfftf1
     MODULE PROCEDURE cfftf1_sp, cfftf1_dp
  END INTERFACE cfftf1
  INTERFACE cffti
     MODULE PROCEDURE cffti_sp, cffti_dp
  END INTERFACE cffti
  INTERFACE cffti1
     MODULE PROCEDURE cffti1_sp, cffti1_dp
  END INTERFACE cffti1
  INTERFACE i_factor
     MODULE PROCEDURE i_factor
  END INTERFACE i_factor
  !  INTERFACE passf
  !     MODULE PROCEDURE passf_sp, passf_dp
  !  END INTERFACE passf
  !  INTERFACE passf2
  !     MODULE PROCEDURE passf2_sp, passf2_dp
  !  END INTERFACE passf2
  !  INTERFACE passf3
  !     MODULE PROCEDURE passf3_sp, passf3_dp
  !  END INTERFACE passf3
  !  INTERFACE passf4
  !     MODULE PROCEDURE passf4_sp, passf4_dp
  !  END INTERFACE passf4
  !  INTERFACE passf5
  !     MODULE PROCEDURE passf5_sp, passf5_dp
  !  END INTERFACE passf5
  ! ------------------------------------------------------------------

CONTAINS

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

  FUNCTION cost_sp(para)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(IN) :: para
    REAL(sp)                           :: cost_sp

    ! local variables
    INTEGER(i4)                         :: n
    INTEGER(i4)                         :: i
    REAL(sp), DIMENSION(:), ALLOCATABLE :: model

    n = size(meas_sp,1)
    allocate(model(n))

    do i = 1, n
       model(i) = 1._sp/(para(1)**2*(1._sp+para(2)**2*real(meas_sp(i),sp)))
    end do

    cost_sp = 0._sp
    do i = 1, n
       cost_sp = cost_sp + abs(log(model(i))-log(real(meas_sp(i),sp)))
    end do

  END FUNCTION cost_sp

  FUNCTION cost_dp(para)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(IN) :: para
    REAL(dp)                           :: cost_dp

    ! local variables
    INTEGER(i4)                         :: n
    INTEGER(i4)                         :: i
    REAL(dp), DIMENSION(:), ALLOCATABLE :: model

    n = size(meas_dp,1)
    allocate(model(n))

    do i = 1, n
       model(i) = 1._dp/(para(1)**2*(1._dp+para(2)**2*real(meas_dp(i),dp)))
    end do

    cost_dp = 0._dp
    do i = 1, n
       cost_dp = cost_dp + abs(log(model(i))-log(real(meas_dp(i),dp)))
    end do

  END FUNCTION cost_dp

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

  SUBROUTINE linres_sp(data,a_min,a_max,tc_min,tc_max,initial_a,initial_tc, bestpara)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(IN)  :: data
    REAL(sp), DIMENSION(2), INTENT(OUT) :: bestpara
    REAL(sp),               INTENT(IN)  :: a_min
    REAL(sp),               INTENT(IN)  :: a_max
    REAL(sp),               INTENT(IN)  :: tc_min
    REAL(sp),               INTENT(IN)  :: tc_max
    REAL(sp),               INTENT(IN)  :: initial_a
    REAL(sp),               INTENT(IN)  :: initial_tc

    ! local variables
    REAL(sp), DIMENSION(2,2)            :: pararanges
    REAL(sp), DIMENSION(2)              :: initial
    ! REAL(sp), DIMENSION(2)              :: para

    initial(1) = initial_a
    initial(2) = initial_tc

    pararanges(1,1) = a_min
    pararanges(1,2) = a_max
    pararanges(2,1) = tc_min
    pararanges(2,2) = tc_max

    call setmeas(data)

    bestpara = nelminrange(cost_sp, initial, pararanges)

  END SUBROUTINE linres_sp

  SUBROUTINE linres_dp(data,a_min,a_max,tc_min,tc_max,initial_a,initial_tc, bestpara)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(IN)  :: data
    REAL(dp), DIMENSION(2), INTENT(OUT) :: bestpara
    REAL(dp),               INTENT(IN)  :: a_min
    REAL(dp),               INTENT(IN)  :: a_max
    REAL(dp),               INTENT(IN)  :: tc_min
    REAL(dp),               INTENT(IN)  :: tc_max
    REAL(dp),               INTENT(IN)  :: initial_a
    REAL(dp),               INTENT(IN)  :: initial_tc

    ! local variables
    REAL(dp), DIMENSION(2,2)            :: pararanges
    REAL(dp), DIMENSION(2)              :: initial
    ! REAL(dp), DIMENSION(2)              :: para

    initial(1) = initial_a
    initial(2) = initial_tc

    pararanges(1,1) = a_min
    pararanges(1,2) = a_max
    pararanges(2,1) = tc_min
    pararanges(2,2) = tc_max

    call setmeas(data)

    bestpara = nelminrange(cost_dp, initial, pararanges)

  END SUBROUTINE linres_dp

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

  SUBROUTINE periodogram_sp(data,output)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),   INTENT(IN)  :: data
    REAL(sp), DIMENSION(:,:), INTENT(OUT) :: output

    ! local variables
    INTEGER(i4)                             :: N, i
    COMPLEX(spc), DIMENSION(:), ALLOCATABLE :: c_data
    ! REAL(sp)                                :: mean_data
    REAL(sp),     DIMENSION(:), ALLOCATABLE :: wsave
    REAL(sp),     DIMENSION(:), ALLOCATABLE :: Iw
    REAL(sp),     DIMENSION(:), ALLOCATABLE :: w

    N = size(data)
    allocate(c_data(N))
    allocate(wsave(4*N+15))

    do i = 1, N
       c_data(i) = cmplx(data(i), 0.0_sp,kind=sp) !- mean_data
    end do

    call cffti(N,wsave)
    call cfftf(N,c_data,wsave)

    allocate(Iw(N))
    allocate(w(N))

    do i = 1, N/2
       Iw(i) = 2*(abs(c_data(i))**2.0_sp)/real(N,sp)
       output(i,2) = Iw(i)
    end do
    do i = 1, N/2
       w(i) = 2*PI_sp*real(i,sp)/real(N,sp)
       output(i,1) = w(i)
    end do

  END SUBROUTINE periodogram_sp

  SUBROUTINE periodogram_dp(data,output)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),   INTENT(IN)  :: data
    REAL(dp), DIMENSION(:,:), INTENT(OUT) :: output

    ! local variables
    INTEGER(i4)                             :: N, i
    COMPLEX(dpc), DIMENSION(:), ALLOCATABLE :: c_data
    ! REAL(dp)                                :: mean_data
    REAL(dp),     DIMENSION(:), ALLOCATABLE :: wsave
    REAL(dp),     DIMENSION(:), ALLOCATABLE :: Iw
    REAL(dp),     DIMENSION(:), ALLOCATABLE :: w

    N = size(data)
    allocate(c_data(N))
    allocate(wsave(4*N+15))

    do i = 1, N
       c_data(i) = cmplx(data(i), 0.0_dp,kind=dp)
    end do

    call cffti(N,wsave)
    call cfftf(N,c_data,wsave)

    allocate(Iw(N))
    allocate(w(N))
    do i = 1, N/2
       Iw(i) = (abs(c_data(i))**2.0_dp)/real(N,dp)
       output(i,2) = Iw(i)
    end do
    do i = 1, N/2
       w(i) = 2*PI_dp*real(i,dp)/real(N,dp)
       output(i,1) = w(i)
    end do

  END SUBROUTINE periodogram_dp

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

  SUBROUTINE setmeas_dp(data)

    REAL(dp), DIMENSION(:), INTENT(IN) :: data

    allocate(meas_dp(size(data)))
    meas_dp(:) = data(:)

  END SUBROUTINE setmeas_dp

  SUBROUTINE setmeas_sp(data)

    REAL(sp), DIMENSION(:), INTENT(IN) :: data

    allocate(meas_sp(size(data)))
    meas_sp(:) = data(:)

  END SUBROUTINE setmeas_sp

  ! ------------------------------------------------------------------
  !                  PRIVATE ROUTINES
  ! ------------------------------------------------------------------

  SUBROUTINE cfftf_sp ( n, c, wsave )
    !
    !*******************************************************************************
    !
    !! CFFTF computes the forward complex discrete Fourier transform.
    !
    !
    !  Discussion:
    !
    !    This process is sometimes called Fourier analysis.
    !
    !    CFFTF computes the Fourier coefficients of a complex periodic sequence.
    !
    !    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 must be initialized by calling CFFTI.
    !
    !    The transform is defined by:
    !
    !      C_out(J) = sum ( 1 <= K <= N )
    !        C_in(K) * exp ( - sqrt ( -1 ) * ( J - 1 ) * ( K - 1 ) * 2 * PI / N )
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Reference:
    !
    !    David Kahaner, Clever Moler, Steven Nash,
    !    Numerical Methods and Software,
    !    Prentice Hall, 1988.
    !
    !    P N Swarztrauber,
    !    Vectorizing the FFT's,
    !    in Parallel Computations,
    !    G. Rodrigue, editor,
    !    Academic Press, 1982, pages 51-83.
    !
    !    B L Buzbee,
    !    The SLATEC Common Math Library,
    !    in Sources and Development of Mathematical Software,
    !    W. Cowell, editor,
    !    Prentice Hall, 1984, pages 302-318.
    !
    !  Parameters:
    !
    !    Input, integer N, the length of the sequence to be transformed.
    !    The method is more efficient when N is the product of small primes.
    !
    !    Input/output, complex C(N).
    !    On input, the data sequence to be transformed.
    !    On output, the Fourier coefficients.
    !
    !    Input, real WSAVE(4*N+15).  The array must be initialized by calling
    !    CFFTI.  A different WSAVE array must be used for each different
    !    value of N.
    !
    implicit none
    !
    integer(i4), intent(in)     :: n
    !
    complex(spc), intent(inout) :: c(n)
    real(sp), intent(in)        :: wsave(4*n+15)
    !********************
    integer(i4)                 :: i
    integer(i4)                 :: wsave_int(4*n+15)
    complex(spc)                :: wsave_complex(4*n+15)

    do i = 1, 4*n+15
       wsave_complex(i) = cmplx(wsave(i),0.0_sp,kind=sp)
       wsave_int(i) = int(wsave(i))
    end do
    !********************
    !
    if ( n <= 1 ) then
       return
    end if

    !call cfftf1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) )
    call cfftf1_sp ( n, c, wsave_complex(1), wsave(2*n+1), wsave_int(4*n+1) )

    return
  END SUBROUTINE cfftf_sp

  SUBROUTINE cfftf_dp ( n, c, wsave )
    !
    implicit none
    !
    integer(i4), intent(in)     :: n
    !
    complex(dpc), intent(inout) :: c(n)
    real(dp), intent(in)        :: wsave(4*n+15)
    !********************
    integer(i4)                 :: i
    integer(i4)                 :: wsave_int(4*n+15)
    complex(dpc)                :: wsave_complex(4*n+15)

    do i = 1, 4*n+15
       wsave_complex(i) = cmplx(wsave(i),0.0_dp,kind=dp)
       wsave_int(i) = int(wsave(i))
    end do
    !********************
    !
    if ( n <= 1 ) then
       return
    end if

    !call cfftf1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) )
    call cfftf1_dp ( n, c, wsave_complex(1), wsave(2*n+1), wsave_int(4*n+1) )

    return
  END SUBROUTINE cfftf_dp

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

  SUBROUTINE cfftf1_sp ( n, c, ch, wa, ifac )
    !
    !*******************************************************************************
    !
    !! CFFTF1 is a lower level routine used by CFFTF.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    !    Input, integer N, the length of the sequence to be transformed.
    !
    !    Input/output, complex C(N).
    !    On input, the data sequence to be transformed.
    !    On output, the Fourier coefficients.
    !
    !    Input, complex CH(N).
    !
    !    Input, real WA(2*N).
    !
    !    Input, integer IFAC(15).
    !    IFAC(1) = N, the number that was factored.
    !    IFAC(2) = NF, the number of factors.
    !    IFAC(3:2+NF), the factors.
    !
    implicit none
    !
    integer(i4)  :: n
    !
    complex(spc) :: c(n)
    complex(spc) :: ch(n)
    integer(i4)  :: idl1
    integer(i4)  :: ido
    integer(i4)  :: ifac(15)
    integer(i4)  :: ip
    integer(i4)  :: iw
    integer(i4)  :: ix2
    integer(i4)  :: ix3
    integer(i4)  :: ix4
    integer(i4)  :: k1
    integer(i4)  :: l1
    integer(i4)  :: l2
    integer(i4)  :: na
    integer(i4)  :: nac
    integer(i4)  :: nf
    real(sp)     :: wa(2*n)

    !***************
    real(sp)     :: c_r(n*2)
    real(sp)     :: ch_r(n*2)
    integer(i4)  :: i, ii

    ii = 1
    do i = 1, n
       c_r(ii) = real(real(c(i),sp),sp)
       ch_r(ii) = real(real(ch(i),sp),sp)
       ii = ii + 1
       c_r(ii) = real(aimag(c(i)),sp)
       ch_r(ii) = real(aimag(ch(i)),sp)
       ii = ii + 1
    end do
    !***************
    !
    nf = ifac(2)
    na = 0
    l1 = 1
    iw = 1

    do k1 = 1, nf

       ip = ifac(k1+2)
       l2 = ip * l1
       ido = n / l2
       idl1 = 2 * ido * l1

       if ( ip == 4 ) then

          ix2 = iw + 2 * ido
          ix3 = ix2 + 2 * ido

          if ( na == 0 ) then
             !call passf4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) )
             call passf4_sp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2), wa(ix3) )
          else
             !call passf4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) )
             call passf4_sp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2), wa(ix3) )
          end if

          na = 1 - na

       else if ( ip == 2 ) then

          if ( na == 0 ) then
             !call passf2 ( 2*ido, l1, c, ch, wa(iw) )
             call passf2_sp ( 2*ido, l1, c_r, ch_r, wa(iw) )
          else
             !call passf2 ( 2*ido, l1, ch, c, wa(iw) )
             call passf2_sp ( 2*ido, l1, ch_r, c_r, wa(iw) )
          end if

          na = 1 - na

       else if ( ip == 3 ) then

          ix2 = iw + 2 * ido

          if ( na == 0 ) then
             !call passf3 ( 2*ido, l1, c, ch, wa(iw), wa(ix2) )
             call passf3_sp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2) )
          else
             !call passf3 ( 2*ido, l1, ch, c, wa(iw), wa(ix2) )
             call passf3_sp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2) )
          end if

          na = 1 - na

       else if ( ip == 5 ) then

          ix2 = iw + 2 * ido
          ix3 = ix2 + 2 * ido
          ix4 = ix3 + 2 * ido

          if ( na == 0 ) then
             !call passf5 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
             call passf5_sp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
          else
             !call passf5 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
             call passf5_sp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
          end if

          na = 1 - na

       else

          if ( na == 0 ) then
             !call passf ( nac, 2*ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) )
             call passf_sp ( nac, 2*ido, ip, l1, idl1, c_r, c_r, c_r, ch_r, ch_r, wa(iw) )
          else
             !call passf ( nac, 2*ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) )
             call passf_sp ( nac, 2*ido, ip, l1, idl1, ch_r, ch_r, ch_r, c_r, c_r, wa(iw) )
          end if

          if ( nac /= 0 ) then
             na = 1 - na
          end if

       end if

       l1 = l2
       iw = iw + ( ip - 1 ) * 2 * ido

    end do

    !*********************
    ii = 1
    do i = 1, n
       c(i) = cmplx(c_r(ii), c_r(ii+1),kind=sp)
       ch(i) = cmplx(ch_r(ii), ch_r(ii+1),kind=sp)
       ii = ii + 2
    end do
    !*********************

    if ( na /= 0 ) then
       c(1:n) = ch(1:n)
    end if
    return
  END SUBROUTINE cfftf1_sp

  SUBROUTINE cfftf1_dp ( n, c, ch, wa, ifac )
    !
    implicit none
    !
    integer(i4)  :: n
    !
    complex(dpc) :: c(n)
    complex(dpc) :: ch(n)
    integer(i4)  :: idl1
    integer(i4)  :: ido
    integer(i4)  :: ifac(15)
    integer(i4)  :: ip
    integer(i4)  :: iw
    integer(i4)  :: ix2
    integer(i4)  :: ix3
    integer(i4)  :: ix4
    integer(i4)  :: k1
    integer(i4)  :: l1
    integer(i4)  :: l2
    integer(i4)  :: na
    integer(i4)  :: nac
    integer(i4)  :: nf
    real(dp)     :: wa(2*n)

    !***************
    real(dp)     :: c_r(n*2)
    real(dp)     :: ch_r(n*2)
    integer(i4)  :: i, ii

    ii = 1
    do i = 1, n
       c_r(ii) = real(real(c(i),dp),dp)
       ch_r(ii) = real(real(ch(i),dp),dp)
       ii = ii + 1
       c_r(ii) = real(aimag(c(i)),dp)
       ch_r(ii) = real(aimag(ch(i)),dp)
       ii = ii + 1
    end do
    !***************
    !
    nf = ifac(2)
    na = 0
    l1 = 1
    iw = 1

    do k1 = 1, nf

       ip = ifac(k1+2)
       l2 = ip * l1
       ido = n / l2
       idl1 = 2 * ido * l1

       if ( ip == 4 ) then

          ix2 = iw + 2 * ido
          ix3 = ix2 + 2 * ido

          if ( na == 0 ) then
             !call passf4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) )
             call passf4_dp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2), wa(ix3) )
          else
             !call passf4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) )
             call passf4_dp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2), wa(ix3) )
          end if

          na = 1 - na

       else if ( ip == 2 ) then

          if ( na == 0 ) then
             !call passf2 ( 2*ido, l1, c, ch, wa(iw) )
             call passf2_dp ( 2*ido, l1, c_r, ch_r, wa(iw) )
          else
             !call passf2 ( 2*ido, l1, ch, c, wa(iw) )
             call passf2_dp ( 2*ido, l1, ch_r, c_r, wa(iw) )
          end if

          na = 1 - na

       else if ( ip == 3 ) then

          ix2 = iw + 2 * ido

          if ( na == 0 ) then
             !call passf3 ( 2*ido, l1, c, ch, wa(iw), wa(ix2) )
             call passf3_dp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2) )
          else
             !call passf3 ( 2*ido, l1, ch, c, wa(iw), wa(ix2) )
             call passf3_dp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2) )
          end if

          na = 1 - na

       else if ( ip == 5 ) then

          ix2 = iw + 2 * ido
          ix3 = ix2 + 2 * ido
          ix4 = ix3 + 2 * ido

          if ( na == 0 ) then
             !call passf5 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
             call passf5_dp ( 2*ido, l1, c_r, ch_r, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
          else
             !call passf5 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
             call passf5_dp ( 2*ido, l1, ch_r, c_r, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
          end if

          na = 1 - na

       else

          if ( na == 0 ) then
             !call passf ( nac, 2*ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) )
             call passf_dp ( nac, 2*ido, ip, l1, idl1, c_r, c_r, c_r, ch_r, ch_r, wa(iw) )
          else
             !call passf ( nac, 2*ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) )
             call passf_dp ( nac, 2*ido, ip, l1, idl1, ch_r, ch_r, ch_r, c_r, c_r, wa(iw) )
          end if

          if ( nac /= 0 ) then
             na = 1 - na
          end if

       end if

       l1 = l2
       iw = iw + ( ip - 1 ) * 2 * ido

    end do

    !*********************
    ii = 1
    do i = 1, n
       c(i) = cmplx(c_r(ii), c_r(ii+1),kind=dp)
       ch(i) = cmplx(ch_r(ii), ch_r(ii+1),kind=dp)
       ii = ii + 2
    end do
    !*********************

    if ( na /= 0 ) then
       c(1:n) = ch(1:n)
    end if
    return
  END SUBROUTINE cfftf1_dp

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

  SUBROUTINE cffti_sp ( n, wsave )
    !
    !*******************************************************************************
    !
    !! CFFTI initializes WSAVE, used in CFFTF and CFFTB.
    !
    !
    !  Discussion:
    !
    !    The prime factorization of N together with a tabulation of the
    !    trigonometric functions are computed and stored in WSAVE.
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Reference:
    !
    !    David Kahaner, Clever Moler, Steven Nash,
    !    Numerical Methods and Software,
    !    Prentice Hall, 1988.
    !
    !    P N Swarztrauber,
    !    Vectorizing the FFT's,
    !    in Parallel Computations,
    !    G. Rodrigue, editor,
    !    Academic Press, 1982, pages 51-83.
    !
    !    B L Buzbee,
    !    The SLATEC Common Math Library,
    !    in Sources and Development of Mathematical Software,
    !    W. Cowell, editor,
    !    Prentice Hall, 1984, pages 302-318.
    !
    !  Parameters:
    !
    !    Input, integer N, the length of the sequence to be transformed.
    !
    !    Output, real WSAVE(4*N+15), contains data, dependent on the value
    !    of N, which is necessary for the CFFTF or CFFTB routines.
    !
    implicit none
    !
    integer(i4), intent(in) :: n
    !
    real(sp), intent(out)   :: wsave(4*n+15)

    !************************
    integer(i4)             :: wsave_int(4*n+15)
    integer(i4)             :: i

    wsave(:)  = 0.0_sp
    wsave_int = int(wsave)

    !************************
    !
    if ( n <= 1 ) then
       return
    end if
    !call cffti1 ( n, wsave(2*n+1), wsave(4*n+1) )
    call cffti1_sp ( n, wsave(2*n+1), wsave_int(4*n+1) )

    !************************
    do i = 4*n+1, 4*n+15
       wsave(i) = real(wsave_int(i),sp)
    end do

    return
  END SUBROUTINE cffti_sp

  SUBROUTINE cffti_dp ( n, wsave )
    !
    implicit none
    !
    integer(i4), intent(in) :: n
    !
    real(dp), intent(out)   :: wsave(4*n+15)

    !************************
    integer(i4) :: wsave_int(4*n+15)
    integer(i4) :: i

    wsave(:)  = 0.0_dp
    wsave_int = int(wsave)
    !************************
    !
    if ( n <= 1 ) then
       return
    end if
    !call cffti1 ( n, wsave(2*n+1), wsave(4*n+1) )
    call cffti1_dp ( n, wsave(2*n+1), wsave_int(4*n+1) )

    !************************
    do i = 4*n+1, 4*n+15
       wsave(i) = real(wsave_int(i),dp)
    end do

    return
  END SUBROUTINE cffti_dp

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

  SUBROUTINE cffti1_sp ( n, wa, ifac )
    !
    !*******************************************************************************
    !
    !! CFFTI1 is a lower level routine used by CFFTI.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    !    Input, integer N, the length of the sequence to be transformed.
    !
    !    Input, real WA(2*N).
    !
    !    Input, integer IFAC(15).
    !    IFAC(1) = N, the number that was factored.
    !    IFAC(2) = NF, the number of factors.
    !    IFAC(3:2+NF), the factors.
    !
    implicit none
    !
    integer(i4), intent(in)    :: n
    integer(i4), intent(inout) :: ifac(15)
    real(sp), intent(inout)    :: wa(2*n)
    !
    real(sp)                   :: arg
    real(sp)                   :: argh
    real(sp)                   :: argld
    real(sp)                   :: fi
    integer(i4)                :: i
    integer(i4)                :: i1
    !integer(i4)               :: ib
    integer(i4)                :: ido
    integer(i4)                :: ii
    integer(i4)                :: ip
    integer(i4)                :: j
    integer(i4)                :: k1
    integer(i4)                :: l1
    integer(i4)                :: l2
    integer(i4)                :: ld
    integer(i4)                :: nf
    !
    call i_factor ( n, ifac )

    nf = ifac(2)

    argh = 2.0E+00 * PI_sp / real ( n,sp )
    i = 2
    l1 = 1

    do k1 = 1, nf

       ip = ifac(k1+2)
       ld = 0
       l2 = l1 * ip
       ido = n / l2

       do j = 1, ip-1

          i1 = i
          wa(i-1) = 1.0E+00
          wa(i) = 0.0E+00
          ld = ld + l1
          fi = 0.0E+00
          argld = real ( ld,sp ) * argh

          do ii = 4, 2*ido+2, 2
             i = i + 2
             fi = fi + 1.0E+00
             arg = fi * argld
             wa(i-1) = cos ( arg )
             wa(i) = sin ( arg )
          end do

          if ( ip > 5 ) then
             wa(i1-1) = wa(i-1)
             wa(i1) = wa(i)
          end if

       end do

       l1 = l2

    end do
    return
  END SUBROUTINE cffti1_sp

  SUBROUTINE cffti1_dp ( n, wa, ifac )
    !
    implicit none
    !
    integer(i4), intent(in)    :: n
    real(dp), intent(inout)    :: wa(2*n)
    integer(i4), intent(inout) :: ifac(15)
    !
    real(dp)                   :: arg
    real(dp)                   :: argh
    real(dp)                   :: argld
    real(dp)                   :: fi
    integer(i4)                :: i
    integer(i4)                :: i1
    !integer(i4)               :: ib
    integer(i4)                :: ido
    integer(i4)                :: ii
    integer(i4)                :: ip
    integer(i4)                :: j
    integer(i4)                :: k1
    integer(i4)                :: l1
    integer(i4)                :: l2
    integer(i4)                :: ld
    integer(i4)                :: nf
    !
    call i_factor ( n, ifac )

    nf = ifac(2)

    argh = 2.0E+00 * PI_dp / real ( n,dp )
    i = 2
    l1 = 1

    do k1 = 1, nf

       ip = ifac(k1+2)
       ld = 0
       l2 = l1 * ip
       ido = n / l2

       do j = 1, ip-1

          i1 = i
          wa(i-1) = 1.0E+00
          wa(i) = 0.0E+00
          ld = ld + l1
          fi = 0.0E+00
          argld = real ( ld,dp ) * argh

          do ii = 4, 2*ido+2, 2
             i = i + 2
             fi = fi + 1.0E+00
             arg = fi * argld
             wa(i-1) = cos ( arg )
             wa(i) = sin ( arg )
          end do

          if ( ip > 5 ) then
             wa(i1-1) = wa(i-1)
             wa(i1) = wa(i)
          end if

       end do

       l1 = l2

    end do
    return
  END SUBROUTINE cffti1_dp

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

  SUBROUTINE i_factor ( n, ifac )
    !
    !*******************************************************************************
    !
    !! I_FACTOR factors an integer.
    !
    !
    !  Modified:
    !
    !    14 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    !    Input, integer N, the number to be factored.
    !
    !    Output, integer IFAC(15).
    !    IFAC(1) = N, the number that was factored.
    !    IFAC(2) = NF, the number of factors.
    !    IFAC(3:2+NF), the factors.
    !
    implicit none
    !
    integer(i4) :: i
    ! integer(i4) :: ib
    integer(i4) :: ifac(15)
    integer(i4) :: j
    integer(i4) :: n
    integer(i4) :: nf
    integer(i4) :: nl
    integer(i4) :: nq
    integer(i4) :: nr
    integer(i4) :: ntry
    !
    ifac(1) = n

    nf = 0
    nl = n

    if ( n == 0 ) then
       nf = 1
       ifac(2) = nf
       ifac(2+nf) = 0
       return
    end if

    if ( n < 1 ) then
       nf = nf + 1
       ifac(2+nf) = -1
       nl = - n
    end if

    if ( nl == 1 ) then
       nf = nf + 1
       ifac(2) = nf
       ifac(2+nf) = 1
       return
    end if

    j = 0

    do while ( nl > 1 )

       j = j + 1
       !
       !  Choose a trial divisor, NTRY.
       !
       if ( j == 1 ) then
          ntry = 4
       else if ( j == 2 ) then
          ntry = 2
       else if ( j == 3 ) then
          ntry = 3
       else if ( j == 4 ) then
          ntry = 5
       else
          ntry = ntry + 2
       end if
       !
       !  Divide by the divisor as many times as possible.
       !
       do

          nq = nl / ntry
          nr = nl - ntry * nq

          if ( nr /= 0 ) then
             exit
          end if

          nl = nq
          nf = nf + 1
          !
          !  Make sure factors of 2 appear in the front of the list.
          !
          if ( ntry /= 2 ) then

             ifac(2+nf) = ntry

          else

             do i = nf, 2, -1
                ifac(i+2) = ifac(i+1)
             end do
             ifac(3) = 2

          end if

       end do

    end do

    ifac(2) = nf

    return
  END SUBROUTINE i_factor

  SUBROUTINE passf_sp ( nac, ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa )
    !
    !*******************************************************************************
    !
    !! PASSF is a lower level routine used by CFFTF1.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    implicit none
    !
    integer(i4)  :: idl1
    integer(i4)  :: ido
    integer(i4)  :: ip
    integer(i4)  :: l1
    !
    real(sp)     :: c1(ido,l1,ip)
    real(sp)     :: c2(idl1,ip)
    real(sp)     :: cc(ido,ip,l1)
    real(sp)     :: ch(ido,l1,ip)
    real(sp)     :: ch2(idl1,ip)
    integer(i4)  :: i
    integer(i4)  :: idij
    integer(i4)  :: idj
    integer(i4)  :: idl
    integer(i4)  :: idlj
    integer(i4)  :: idp
    integer(i4)  :: ik
    integer(i4)  :: inc
    integer(i4)  :: ipph
    integer(i4)  :: j
    integer(i4)  :: jc
    integer(i4)  :: k
    integer(i4)  :: l
    integer(i4)  :: lc
    integer(i4)  :: nac
    !integer(i4) :: nt
    real(sp)     :: wa(*)
    real(sp)     :: wai
    real(sp)     :: war
    !
    !nt = ip * idl1
    ipph = (ip+1) / 2
    idp = ip * ido

    if ( ido >= l1 ) then

       do j = 2, ipph
          jc = ip + 2 - j
          ch(1:ido,1:l1,j)  = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1)
          ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1)
       end do

       ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1)

    else

       do j = 2, ipph
          jc = ip + 2 - j
          ch(1:ido,1:l1,j)  = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1)
          ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1)
       end do

       ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1)

    end if

    idl = 2 - ido
    inc = 0

    do l = 2, ipph

       lc = ip + 2 - l
       idl = idl + ido

       do ik = 1, idl1
          c2(ik,l)  = ch2(ik,1) + wa(idl-1) * ch2(ik,2)
          c2(ik,lc) =           - wa(idl)   * ch2(ik,ip)
       end do

       idlj = idl
       inc = inc + ido

       do j = 3, ipph

          jc = ip + 2 - j

          idlj = idlj + inc
          if ( idlj > idp ) then
             idlj = idlj - idp
          end if

          war = wa(idlj-1)
          wai = wa(idlj)

          do ik = 1, idl1
             c2(ik,l)  = c2(ik,l)  + war * ch2(ik,j)
             c2(ik,lc) = c2(ik,lc) - wai * ch2(ik,jc)
          end do

       end do

    end do

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

    do j = 2, ipph
       jc = ip + 2 - j
       do ik = 2, idl1, 2
          ch2(ik-1,j)  = c2(ik-1,j) - c2(ik,jc)
          ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
          ch2(ik,j)    = c2(ik,j)   + c2(ik-1,jc)
          ch2(ik,jc)   = c2(ik,j)   - c2(ik-1,jc)
       end do
    end do

    if ( ido == 2 ) then
       nac = 1
       return
    end if

    nac = 0

    c2(1:idl1,1)    = ch2(1:idl1,1)
    c1(1,1:l1,2:ip) = ch(1,1:l1,2:ip)
    c1(2,1:l1,2:ip) = ch(2,1:l1,2:ip)

    if ( ( ido / 2 ) <= l1 ) then

       idij = 0
       do j = 2, ip
          idij = idij + 2
          do i = 4, ido, 2
             idij = idij + 2
             c1(i-1,1:l1,j) = wa(idij-1) * ch(i-1,1:l1,j) + wa(idij) * ch(i,1:l1,j)
             c1(i,1:l1,j)   = wa(idij-1) * ch(i,1:l1,j)   - wa(idij) * ch(i-1,1:l1,j)
          end do
       end do

    else

       idj = 2 - ido

       do j = 2, ip
          idj = idj + ido
          do k = 1, l1
             idij = idj
             do i = 4, ido, 2
                idij = idij + 2
                c1(i-1,k,j) = wa(idij-1) * ch(i-1,k,j) + wa(idij) * ch(i,k,j)
                c1(i,k,j)   = wa(idij-1) * ch(i,k,j)   - wa(idij) * ch(i-1,k,j)
             end do
          end do
       end do

    end if

    return
  END SUBROUTINE passf_sp

  SUBROUTINE passf_dp ( nac, ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa )
    !
    implicit none
    !
    integer(i4)  :: idl1
    integer(i4)  :: ido
    integer(i4)  :: ip
    integer(i4)  :: l1
    !
    real(dp)     :: c1(ido,l1,ip)
    real(dp)     :: c2(idl1,ip)
    real(dp)     :: cc(ido,ip,l1)
    real(dp)     :: ch(ido,l1,ip)
    real(dp)     :: ch2(idl1,ip)
    integer(i4)  :: i
    integer(i4)  :: idij
    integer(i4)  :: idj
    integer(i4)  :: idl
    integer(i4)  :: idlj
    integer(i4)  :: idp
    integer(i4)  :: ik
    integer(i4)  :: inc
    integer(i4)  :: ipph
    integer(i4)  :: j
    integer(i4)  :: jc
    integer(i4)  :: k
    integer(i4)  :: l
    integer(i4)  :: lc
    integer(i4)  :: nac
    !integer(i4) :: nt
    real(dp)     :: wa(*)
    real(dp)     :: wai
    real(dp)     :: war
    !
    !nt = ip * idl1
    ipph = (ip+1) / 2
    idp = ip * ido

    if ( ido >= l1 ) then

       do j = 2, ipph
          jc = ip + 2 - j
          ch(1:ido,1:l1,j)  = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1)
          ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1)
       end do

       ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1)

    else

       do j = 2, ipph
          jc = ip + 2 - j
          ch(1:ido,1:l1,j)  = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1)
          ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1)
       end do

       ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1)

    end if

    idl = 2 - ido
    inc = 0

    do l = 2, ipph

       lc = ip + 2 - l
       idl = idl + ido

       do ik = 1, idl1
          c2(ik,l)  = ch2(ik,1) + wa(idl-1) * ch2(ik,2)
          c2(ik,lc) =           - wa(idl)   * ch2(ik,ip)
       end do

       idlj = idl
       inc = inc + ido

       do j = 3, ipph

          jc = ip + 2 - j

          idlj = idlj + inc
          if ( idlj > idp ) then
             idlj = idlj - idp
          end if

          war = wa(idlj-1)
          wai = wa(idlj)

          do ik = 1, idl1
             c2(ik,l)  = c2(ik,l)  + war * ch2(ik,j)
             c2(ik,lc) = c2(ik,lc) - wai * ch2(ik,jc)
          end do

       end do

    end do

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

    do j = 2, ipph
       jc = ip + 2 - j
       do ik = 2, idl1, 2
          ch2(ik-1,j)  = c2(ik-1,j) - c2(ik,jc)
          ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
          ch2(ik,j)    = c2(ik,j)   + c2(ik-1,jc)
          ch2(ik,jc)   = c2(ik,j)   - c2(ik-1,jc)
       end do
    end do

    if ( ido == 2 ) then
       nac = 1
       return
    end if

    nac = 0

    c2(1:idl1,1)    = ch2(1:idl1,1)
    c1(1,1:l1,2:ip) = ch(1,1:l1,2:ip)
    c1(2,1:l1,2:ip) = ch(2,1:l1,2:ip)

    if ( ( ido / 2 ) <= l1 ) then

       idij = 0
       do j = 2, ip
          idij = idij + 2
          do i = 4, ido, 2
             idij = idij + 2
             c1(i-1,1:l1,j) = wa(idij-1) * ch(i-1,1:l1,j) + wa(idij) * ch(i,1:l1,j)
             c1(i,1:l1,j)   = wa(idij-1) * ch(i,1:l1,j)   - wa(idij) * ch(i-1,1:l1,j)
          end do
       end do

    else

       idj = 2 - ido

       do j = 2, ip
          idj = idj + ido
          do k = 1, l1
             idij = idj
             do i = 4, ido, 2
                idij = idij + 2
                c1(i-1,k,j) = wa(idij-1) * ch(i-1,k,j) + wa(idij) * ch(i,k,j)
                c1(i,k,j)   = wa(idij-1) * ch(i,k,j)   - wa(idij) * ch(i-1,k,j)
             end do
          end do
       end do

    end if

    return
  END SUBROUTINE passf_dp

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

  SUBROUTINE passf2_sp ( ido, l1, cc, ch, wa1 )
    !
    !*******************************************************************************
    !
    !! PASSF2 is a lower level routine used by CFFTF1.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    implicit none
    !
    integer(i4) :: ido
    integer(i4) :: l1
    !
    real(sp)    :: cc(ido,2,l1)
    real(sp)    :: ch(ido,l1,2)
    integer(i4) :: i
    integer(i4) :: k
    real(sp)    :: ti2
    real(sp)    :: tr2
    real(sp)    :: wa1(ido)
    !
    if ( ido <= 2 ) then

       ch(1,1:l1,1) = cc(1,1,1:l1) + cc(1,2,1:l1)
       ch(1,1:l1,2) = cc(1,1,1:l1) - cc(1,2,1:l1)
       ch(2,1:l1,1) = cc(2,1,1:l1) + cc(2,2,1:l1)
       ch(2,1:l1,2) = cc(2,1,1:l1) - cc(2,2,1:l1)

    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
    return
  END SUBROUTINE passf2_sp

  SUBROUTINE passf2_dp ( ido, l1, cc, ch, wa1 )
    !
    implicit none
    !
    integer(i4) :: ido
    integer(i4) :: l1
    !
    real(dp)    :: cc(ido,2,l1)
    real(dp)    :: ch(ido,l1,2)
    integer(i4) :: i
    integer(i4) :: k
    real(dp)    :: ti2
    real(dp)    :: tr2
    real(dp)    :: wa1(ido)
    !
    if ( ido <= 2 ) then

       ch(1,1:l1,1) = cc(1,1,1:l1) + cc(1,2,1:l1)
       ch(1,1:l1,2) = cc(1,1,1:l1) - cc(1,2,1:l1)
       ch(2,1:l1,1) = cc(2,1,1:l1) + cc(2,2,1:l1)
       ch(2,1:l1,2) = cc(2,1,1:l1) - cc(2,2,1:l1)

    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
    return
  END SUBROUTINE passf2_dp

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

  SUBROUTINE passf3_sp ( ido, l1, cc, ch, wa1, wa2 )
    !
    !*******************************************************************************
    !
    !! PASSF3 is a lower level routine used by CFFTF1.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    implicit none
    !
    integer(i4)         :: ido
    integer(i4)         :: l1
    !
    real(sp)            :: cc(ido,3,l1)
    real(sp)            :: ch(ido,l1,3)
    real(sp)            :: ci2
    real(sp)            :: ci3
    real(sp)            :: cr2
    real(sp)            :: cr3
    real(sp)            :: di2
    real(sp)            :: di3
    real(sp)            :: dr2
    real(sp)            :: dr3
    integer(i4)         :: i
    integer(i4)         :: k
    real(sp)            :: taui
    real(sp), parameter :: taur = -0.5E+00
    real(sp)            :: ti2
    real(sp)            :: tr2
    real(sp)            :: wa1(ido)
    real(sp)            :: wa2(ido)
    !
    taui = - sqrt ( 3.0E+00 ) / 2.0E+00

    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf3_sp

  SUBROUTINE passf3_dp ( ido, l1, cc, ch, wa1, wa2 )
    !
    implicit none
    !
    integer(i4)         :: ido
    integer(i4)         :: l1
    !
    real(dp)            :: cc(ido,3,l1)
    real(dp)            :: ch(ido,l1,3)
    real(dp)            :: ci2
    real(dp)            :: ci3
    real(dp)            :: cr2
    real(dp)            :: cr3
    real(dp)            :: di2
    real(dp)            :: di3
    real(dp)            :: dr2
    real(dp)            :: dr3
    integer(i4)         :: i
    integer(i4)         :: k
    real(dp)            :: taui
    real(dp), parameter :: taur = -0.5E+00
    real(dp)            :: ti2
    real(dp)            :: tr2
    real(dp)            :: wa1(ido)
    real(dp)            :: wa2(ido)
    !
    taui = - sqrt ( 3.0E+00 ) / 2.0E+00

    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf3_dp

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

  SUBROUTINE passf4_sp ( ido, l1, cc, ch, wa1, wa2, wa3 )
    !
    !*******************************************************************************
    !
    !! PASSF4 is a lower level routine used by CFFTF1.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    implicit none
    !
    integer(i4) :: ido
    integer(i4) :: l1
    !
    real(sp)    :: cc(ido,4,l1)
    real(sp)    :: ch(ido,l1,4)
    !  real(sp) :: ci1
    real(sp)    :: ci2
    real(sp)    :: ci3
    real(sp)    :: ci4
    ! real(sp)  :: cr1
    real(sp)    :: cr2
    real(sp)    :: cr3
    real(sp)    :: cr4
    integer(i4) :: i
    integer(i4) :: k
    real(sp)    :: ti1
    real(sp)    :: ti2
    real(sp)    :: ti3
    real(sp)    :: ti4
    real(sp)    :: tr1
    real(sp)    :: tr2
    real(sp)    :: tr3
    real(sp)    :: tr4
    real(sp)    :: wa1(ido)
    real(sp)    :: wa2(ido)
    real(sp)    :: wa3(ido)
    !
    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf4_sp

  SUBROUTINE passf4_dp ( ido, l1, cc, ch, wa1, wa2, wa3 )
    !
    implicit none
    !
    integer(i4) :: ido
    integer(i4) :: l1
    !
    real(dp)    :: cc(ido,4,l1)
    real(dp)    :: ch(ido,l1,4)
    ! real(dp)  :: ci1
    real(dp)    :: ci2
    real(dp)    :: ci3
    real(dp)    :: ci4
    ! real(dp)  :: cr1
    real(dp)    :: cr2
    real(dp)    :: cr3
    real(dp)    :: cr4
    integer(i4) :: i
    integer(i4) :: k
    real(dp)    :: ti1
    real(dp)    :: ti2
    real(dp)    :: ti3
    real(dp)    :: ti4
    real(dp)    :: tr1
    real(dp)    :: tr2
    real(dp)    :: tr3
    real(dp)    :: tr4
    real(dp)    :: wa1(ido)
    real(dp)    :: wa2(ido)
    real(dp)    :: wa3(ido)
    !
    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf4_dp

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

  SUBROUTINE passf5_sp ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 )
    !
    !*******************************************************************************
    !
    !! PASSF5 is a lower level routine used by CFFTF1.
    !
    !
    !  Modified:
    !
    !    09 March 2001
    !
    !  Author:
    !
    !    Paul Swarztrauber,
    !    National Center for Atmospheric Research
    !
    !  Parameters:
    !
    implicit none
    !
    integer(i4) ido
    integer(i4) l1
    !
    real(sp) :: cc(ido,5,l1)
    real(sp) :: ch(ido,l1,5)
    real(sp) :: ci2
    real(sp) :: ci3
    real(sp) :: ci4
    real(sp) :: ci5
    real(sp) :: cr2
    real(sp) :: cr3
    real(sp) :: cr4
    real(sp) :: cr5
    real(sp) :: di2
    real(sp) :: di3
    real(sp) :: di4
    real(sp) :: di5
    real(sp) :: dr2
    real(sp) :: dr3
    real(sp) :: dr4
    real(sp) :: dr5
    integer(i4) i
    integer(i4) k
    real(sp), parameter :: ti11 = -0.951056516295154E+00
    real(sp), parameter :: ti12 = -0.587785252292473E+00
    real(sp) :: ti2
    real(sp) :: ti3
    real(sp) :: ti4
    real(sp) :: ti5
    real(sp) :: tr2
    real(sp) :: tr3
    real(sp) :: tr4
    real(sp) :: tr5
    !
    !  cos ( 72 ) = +0.3090
    !
    real(sp), parameter :: tr11 =  0.309016994374947E+00
    !
    !  cos ( 36 ) = +0.809016
    !
    real(sp), parameter :: tr12 = -0.809016994374947E+00
    real(sp) :: wa1(ido)
    real(sp) :: wa2(ido)
    real(sp) :: wa3(ido)
    real(sp) :: wa4(ido)
    !
    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf5_sp

  SUBROUTINE passf5_dp ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 )
    !
    implicit none
    !
    integer(i4) ido
    integer(i4) l1
    !
    real(dp) :: cc(ido,5,l1)
    real(dp) :: ch(ido,l1,5)
    real(dp) :: ci2
    real(dp) :: ci3
    real(dp) :: ci4
    real(dp) :: ci5
    real(dp) :: cr2
    real(dp) :: cr3
    real(dp) :: cr4
    real(dp) :: cr5
    real(dp) :: di2
    real(dp) :: di3
    real(dp) :: di4
    real(dp) :: di5
    real(dp) :: dr2
    real(dp) :: dr3
    real(dp) :: dr4
    real(dp) :: dr5
    integer(i4) i
    integer(i4) k
    real(dp), parameter :: ti11 = -0.951056516295154E+00
    real(dp), parameter :: ti12 = -0.587785252292473E+00
    real(dp) :: ti2
    real(dp) :: ti3
    real(dp) :: ti4
    real(dp) :: ti5
    real(dp) :: tr2
    real(dp) :: tr3
    real(dp) :: tr4
    real(dp) :: tr5
    !
    !  cos ( 72 ) = +0.3090
    !
    real(dp), parameter :: tr11 =  0.309016994374947E+00
    !
    !  cos ( 36 ) = +0.809016
    !
    real(dp), parameter :: tr12 = -0.809016994374947E+00
    real(dp) :: wa1(ido)
    real(dp) :: wa2(ido)
    real(dp) :: wa3(ido)
    real(dp) :: wa4(ido)
    !
    if ( ido == 2 ) then

       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

    else

       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 if
    return
  END SUBROUTINE passf5_dp

END MODULE mo_specan


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_QPP_EXAMPLE
   USE GALAHAD_QPP_double                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
   TYPE ( QPP_dims_type ) :: d
   TYPE ( QPP_map_type ) :: map
   TYPE ( QPP_control_type ) :: control
   TYPE ( QPP_inform_type ) :: info
   TYPE ( QPT_problem_type ) :: p
   INTEGER :: i, j, s
   INTEGER, PARAMETER :: n = 4, m = 2, h_ne = 5, a_ne = 5
   REAL ( KIND = wp ) :: X_orig( n )
! sparse co-ordinate storage format
   CALL SMT_put( p%H%type, 'COORDINATE', s )  ! Specify co-ordinate
   CALL SMT_put( p%A%type, 'COORDINATE', s )  ! storage for H and A
   ALLOCATE( p%H%val( h_ne ), p%H%row( h_ne ), p%H%col( h_ne ) )
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%H%val = (/ 1.0_wp, 2.0_wp, -1.0_wp, 5.0_wp, 4.0_wp /) ! Hessian H
   p%H%row = (/ 1, 2, 3, 3, 4 /)                           ! NB lower triangle
   p%H%col = (/ 1, 2, 2, 3, 1 /) ; p%H%ne = h_ne
   p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /)  ! Jacobian A
   p%A%row = (/ 1, 1, 2, 2, 2 /)
   p%A%col = (/ 1, 2, 2, 3, 4 /) ; p%A%ne = a_ne
! sparse row-wise storage format
!  CALL SMT_put( p%H%type, 'SPARSE_BY_ROWS', s )  ! Specify sparse-by-rows
!  CALL SMT_put( p%A%type, 'SPARSE_BY_ROWS', s )  ! storage for H and A
!  ALLOCATE( p%H%val( h_ne ), p%H%col( h_ne ), p%H%ptr( n + 1 ) )
!  ALLOCATE( p%A%val( a_ne ), p%A%col( a_ne ), p%A%ptr( m + 1 ) )
!  p%H%val = (/ 1.0_wp, 2.0_wp, -1.0_wp, 5.0_wp, 4.0_wp /) ! Hessian H
!  p%H%col = (/ 1, 2, 2, 3, 1 /)                           ! NB lower triangular
!  p%H%ptr = (/ 1, 2, 3, 5, 6 /)                           ! Set row pointers
!  p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /)  ! Jacobian A
!  p%A%col = (/ 1, 2, 2, 3, 4 /)
!  p%A%ptr = (/ 1, 3, 6 /)                                 ! Set row pointers
! dense storage format
!  CALL SMT_put( p%H%type, 'DENSE', s )  ! Specify dense
!  CALL SMT_put( p%A%type, 'DENSE', s )  ! storage for H and A
!  ALLOCATE( p%H%val( n * ( n + 1 ) / 2) )
!  ALLOCATE( p%A%val( n * m ) )
!  p%H%val = (/ 1.0_wp, 0.0_wp, 2.0_wp, 0.0_wp, -1.0_wp, 5.0_wp,              &
!               4.0_wp, 0.0_wp, 0.0_wp, 0.0_wp /)          ! Hessian
!  p%A%val = (/ 2.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 1.0_wp,               &
!               1.0_wp, 1.0_wp /)                          ! Jacobian
! arrays complete
   ALLOCATE( p%G( n ), p%X_l( n ), p%X_u( n ) )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ) )
   ALLOCATE( p%X( n ), p%Y( m ), p%Z( n ) )
   p%n = n ; p%m = m ; p%f = 1.0_wp           ! dimensions & objective constant
   p%Hessian_kind = - 1 ; p%gradient_kind = - 1 ! generic quadratic program
   p%G = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! objective gradient
   p%C_l = (/ 1.0_wp, 2.0_wp /)               ! constraint lower bound
   p%C_u = (/ 2.0_wp, 2.0_wp /)               ! constraint upper bound
   p%X_l = (/ - 1.0_wp, - infinity, 1.0_wp, - infinity /) ! variable lower bound
   p%X_u = (/ 1.0_wp, infinity, 1.0_wp, 2.0_wp /)         ! variable upper bound
   CALL QPP_initialize( map, control )          ! Initialize control parameters
   control%infinity = infinity                   ! Set infinity
! reorder problem
   CALL QPP_reorder( map, control, info, d, p, .TRUE., .TRUE., .TRUE. )
   IF ( info%status /= 0 ) & !  Error returns
     WRITE( 6, "( ' QPP_solve exit status = ', I6 ) " ) info%status
   WRITE( 6, "( ' problem now involves ', I1, ' variables and ',               &
  &       I1, ' constraints. f is now', ES12.4 )" ) p%n, p%m, p%f
! re-ordered variables
   WRITE( 6, "( /, 5X, 'i', 6x, 'v', 11X, 'l', 11X, 'u', 11X, 'z', 11X,        &
  &            'g', 6X, 'type' )" )
   DO i = 1, d%x_free                      ! free variables
     WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), '  '
   END DO
   DO i = d%x_free + 1, d%x_l_start - 1    ! non-negativities
    WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), '0< '
   END DO
   DO i = d%x_l_start, d%x_u_start - 1     ! lower-bounded variables
    WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), 'l< '
   END DO
   DO i = d%x_u_start, d%x_l_end           ! range-bounded variables
    WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), 'l<u'
   END DO
   DO i = d%x_l_end + 1, d%x_u_end         ! upper-bounded variables
    WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), ' <u'
   END DO
   DO i = d%x_u_end + 1, p%n                ! non-positivities
    WRITE( 6, 10 ) i, p%X( i ), p%X_l( i ), p%X_u( i ), p%Z( i ), p%G( i ), ' <0'
   END DO
! re-ordered constraints
   WRITE( 6, "( /, 5X,'i', 5x, 'A*v', 10X, 'l', 11X, 'u', 11X, 'y',            &
  &                6X, 'type' )" )
   DO i = 1, d%c_l_start - 1                ! equality constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l=u'
   END DO
   DO i = d%c_l_start, d%c_u_start - 1      ! lower-bounded constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l< '
   END DO
   DO i = d%c_u_start, d%c_l_end            ! range-bounded constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l<u'
   END DO
   DO i = d%c_l_end + 1, d%c_u_end          ! upper-bounded constraints
     WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), ' <u'
   END DO
! re-ordered matrices
   WRITE( 6, 30 ) 'Hessian ', ( ( 'H', i, p%H%col( j ), p%H%val( j ),          &
     j = p%H%ptr( i ), p%H%ptr( i + 1 ) - 1 ), i = 1, p%n ) ! Hessian
   WRITE( 6, 30 ) 'Jacobian', ( ( 'A', i, p%A%col( j ), p%A%val( j ),          &
     j = p%A%ptr( i ), p%A%ptr( i + 1 ) - 1 ), i = 1, p%m )  ! Jacobian
   p%X( : 3 ) = (/ 1.6_wp, 0.2_wp, -0.6_wp /)
   CALL QPP_get_values( map, info, p, X_val = X_orig )
   WRITE( 6, "( /, ' solution = ', ( 4ES12.4 ) )" ) X_orig( : n )
! recover constraint bounds
   CALL QPP_restore( map, info, p, get_c_bounds = .TRUE. )
! change upper bound
   p%C_u( 1 ) = 3.0_wp
! reorder new problem
   CALL QPP_apply( map, info, p, get_c_bounds = .TRUE. )
! re-ordered new constraints
   WRITE( 6, "( /, 5X,'i', 5x, 'A*v', 10X, 'l', 11X, 'u', 11X, 'y',            &
  &                6X, 'type' )" )
   DO i = 1, d%c_l_start - 1                ! equality constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l=u'
   END DO
   DO i = d%c_l_start, d%c_u_start - 1      ! lower-bounded constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l< '
   END DO
   DO i = d%c_u_start, d%c_l_end            ! range-bounded constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), 'l<u'
   END DO
   DO i = d%c_l_end + 1, d%c_u_end          ! upper-bounded constraints
    WRITE( 6, 20 ) i, p%C( i ), p%C_l( i ), p%C_u( i ), p%Y( i ), ' <u'
   END DO
   CALL QPP_terminate( map, control, info ) !  delete internal workspace
10 FORMAT( I6, 5ES12.4, 2X, A3 )
20 FORMAT( I6, 4ES12.4, 2X, A3 )
30 FORMAT( /, 1X, A8, /, ( :, 3 ( 1X, A1, '(', 2I2, ') =', ES12.4, : ) ) )
   END PROGRAM GALAHAD_QPP_EXAMPLE


PROGRAM append_test

use mo_kind,   only: i4
use mo_ansi_colors, only: color, c_red, c_green
#ifndef __ABSOFT__
use mo_append, only: append, paste

implicit none

integer(i4), dimension(:),   allocatable  :: vector1_i4, vector2_i4
integer(i4), dimension(2)                 :: vector3_i4

integer(i4), dimension(:,:), allocatable  :: matrix1_i4, matrix2_i4, matrix3_i4, matrix4_i4

character(256), dimension(:),   allocatable :: vector1_c, vector2_c
character(256), dimension(2)                :: vector3_c
character(256), dimension(:,:), allocatable :: matrix1_c, matrix2_c, matrix3_c, matrix4_c
#endif

logical :: isgood

isgood = .true.

#ifndef __ABSOFT__
! ---------------------------------------------------------------------------
!                           TEST APPEND
! ---------------------------------------------------------------------------

allocate(vector2_i4(4))
allocate(matrix1_i4(2,2), matrix2_i4(3,2))

vector2_i4 = 2_i4
vector3_i4 = 3_i4

matrix1_i4 = 5_i4
matrix2_i4 = 3_i4

print*, '(A) non-allocated vector will be appended by  vector2'
print*, '    vector2 = (/ ',vector2_i4,' /) ^ T'
call append(vector1_i4, vector2_i4)
print*, '    result  = (/ ',vector1_i4,' /) ^ T'
print*, ' '
if ( any(vector1_i4 .ne. (/ 2_i4,2_i4,2_i4,2_i4 /)) ) isgood=.false.

print*, '(B) vector1  will be appended by  vector3'
print*, '    vector1 = (/ ',vector1_i4,' /) ^ T'
print*, '    vector3 = (/ ',vector3_i4,' /) ^ T'
call append(vector1_i4, vector3_i4)
print*, '    result  = (/ ',vector1_i4,' /) ^ T'
print*, ' '
if ( any(vector1_i4 .ne. (/ 2_i4,2_i4,2_i4,2_i4, 3_i4,3_i4 /)) ) isgood=.false.

print*, '(C) vector1  will be appended by scalar 5_i4'
print*, '    vector1 = (/ ',vector1_i4,' /) ^ T'
call append(vector1_i4, 5_i4)
print*, '    result  = (/ ',vector1_i4,' /)'
print*, ' '
if ( any(vector1_i4 .ne. (/ 2_i4,2_i4,2_i4,2_i4, 3_i4,3_i4, 5_i4 /)) ) isgood=.false.

print*, '(D) matrix1 will be appended by matrix 2'
print*, '    matrix1 = (/', matrix1_i4(1,:)
print*, '                ', matrix1_i4(2,:),' /)'
print*, '    matrix2 = (/', matrix2_i4(1,:)
print*, '                ', matrix2_i4(2,:)
print*, '                ', matrix2_i4(3,:),' /)'
call append(matrix1_i4, matrix2_i4)
print*, '    result  = (/ ',matrix1_i4(1,:)
print*, '                 ',matrix1_i4(2,:)
print*, '                 ',matrix1_i4(3,:)
print*, '                 ',matrix1_i4(4,:)
print*, '                 ',matrix1_i4(5,:),' /)'
print*, ' '
if ( any(matrix1_i4(1,:) .ne. (/ 5_i4,5_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(2,:) .ne. (/ 5_i4,5_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(3,:) .ne. (/ 3_i4,3_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(4,:) .ne. (/ 3_i4,3_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(5,:) .ne. (/ 3_i4,3_i4 /)) ) isgood=.false.

deallocate(vector1_i4)
deallocate(vector2_i4)
deallocate(matrix1_i4, matrix2_i4)

! Character
allocate(vector2_c(4))
allocate(matrix1_c(2,2), matrix2_c(3,2))

vector2_c = 'B'
vector3_c = 'C'

matrix1_c = 'E'
matrix2_c = 'C'

print*, '(A) non-allocated character vector will be appended by character vector2'
print*, '    vector2(1) = ',trim(vector2_c(1))
call append(vector1_c, vector2_c)
print*, '    result(1)  = ',trim(vector1_c(1))
print*, ' '
if (trim(vector1_c(1)) /= 'B') isgood=.false.

print*, '(B) character vector1  will be appended by character vector3'
print*, '    vector3(1) = ',trim(vector3_c(1))
call append(vector1_c, vector3_c)
print*, '    result(4)  = ',trim(vector1_c(4))
print*, '    result(5)  = ',trim(vector1_c(5))
print*, ' '
if (trim(vector1_c(5)) /= 'C') isgood=.false.

print*, '(C) character vector1 will be appended by scalar E'
call append(vector1_c, 'E')
print*, '    result(6)  = ',trim(vector1_c(6))
print*, '    result(7)  = ',trim(vector1_c(7))
print*, ' '
if (trim(vector1_c(7)) /= 'E') isgood=.false.

print*, '(D) character matrix1 will be appended by character matrix 2'
print*, '    matrix1(1,1) = ', trim(matrix1_c(2,2))
print*, '    matrix2(1,1) = ', trim(matrix2_c(1,1))
call append(matrix1_c, matrix2_c)
print*, '    matrix1(2,2) = ', trim(matrix1_c(2,2))
print*, '    matrix1(3,2) = ', trim(matrix1_c(3,2))
print*, ' '
if (trim(matrix1_c(3,2)) /= 'C') isgood=.false.

print*, '(E) character matrix1 will be appended by first column only of character matrix 2'
call append(matrix1_c, matrix2_c(:,:1), fill_value = 'X' )
print*, '    matrix1(7,2) = ', trim(matrix1_c(7,2))

if (trim( matrix1_c(7,2 ) ) .ne. 'X' ) isgood=.false.

deallocate(vector1_c)
deallocate(vector2_c)
deallocate(matrix1_c, matrix2_c)

! ---------------------------------------------------------------------------
!                           TEST PASTE
! ---------------------------------------------------------------------------

allocate(matrix2_i4(2,2), matrix3_i4(2,3), matrix4_i4(1,3))

matrix2_i4 = 5_i4
matrix3_i4 = 3_i4
matrix4_i4 = 2_i4

print*, '(A) non-allocated matrix will be pasted by  matrix2'
print*, '    matrix2 = (/', matrix2_i4(1,:)
print*, '                 ',matrix2_i4(2,:),' /)'
call paste(matrix1_i4, matrix2_i4)
print*, '    result  = (/ ',matrix1_i4(1,:)
print*, '                 ',matrix1_i4(2,:),' /)'
print*, ' '
if ( any(matrix1_i4(1,:) .ne. (/ 5_i4,5_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(2,:) .ne. (/ 5_i4,5_i4 /)) ) isgood=.false.

print*, '(B) matrix1  will be pasted by matrix3'
print*, '    matrix1 = (/ ', matrix1_i4(1,:)
print*, '                 ', matrix1_i4(2,:),' /)'
print*, '    matrix3 = (/ ', matrix3_i4(1,:)
print*, '                 ', matrix3_i4(2,:),' /)'
call paste(matrix1_i4, matrix3_i4)
print*, '    result  = (/ ', matrix1_i4(1,:)
print*, '                 ', matrix1_i4(2,:),' /)'
print*, ' '
if ( any(matrix1_i4(1,:) .ne. (/ 5_i4,5_i4, 3_i4,3_i4,3_i4 /)) ) isgood=.false.
if ( any(matrix1_i4(2,:) .ne. (/ 5_i4,5_i4, 3_i4,3_i4,3_i4 /)) ) isgood=.false.

print*, '(C) matrix4  will be pasted by scalar 5_i4'
print*, '    matrix4 = (/ ', matrix4_i4(1,:),' /)'
call paste(matrix4_i4, 5_i4)
print*, '    result  = (/ ', matrix4_i4(1,:),' /)'
print*, ' '
if ( any(matrix4_i4(1,:) .ne. (/ 2_i4,2_i4,2_i4, 5_i4 /)) ) isgood=.false.

deallocate( matrix2_i4, matrix3_i4 )
allocate(matrix2_i4(2,2), matrix3_i4(2,3) )
matrix2_i4 = 5_i4
matrix3_i4 = 3_i4

print*, '(D) matrix2 will be pasted by the first row of matrix3'
print*, '    matrix2 = (/', matrix2_i4(1,:)
print*, '                ',matrix2_i4(2,:),' /)'
print*, '    matrix3 = (/', matrix3_i4(1,:)
print*, '                ',matrix3_i4(2,:),' /)'
call paste(matrix2_i4, matrix3_i4(:1,:), fill_value = -9999_i4 )
print*, '    result  = (/', matrix2_i4(1,:)
print*, '                ',matrix2_i4(2,:),'/)'
if ( matrix2_i4(2,3) .ne. -9999_i4 ) isgood=.false.

deallocate(matrix1_i4, matrix2_i4, matrix3_i4, matrix4_i4)

! Character
allocate(matrix2_c(2,2), matrix3_c(2,3), matrix4_c(1,3))

matrix2_c = 'E'
matrix3_c = 'C'
matrix4_c = 'B'

print*, '(A) non-allocated character matrix will be pasted by character matrix2'
print*, '    matrix2(1,1) = ', trim(matrix2_c(1,1))
call paste(matrix1_c, matrix2_c)
print*, '    matrix1(1,1) = ', trim(matrix1_c(1,1))
print*, ' '
if (trim(matrix1_c(1,1)) /= 'E') isgood=.false.

print*, '(B) character matrix1 will be pasted by character matrix3'
print*, '    matrix1(2,2) = ', trim(matrix1_c(2,2))
print*, '    matrix3(1,1) = ', trim(matrix3_c(1,1))
call paste(matrix1_c, matrix3_c)
print*, '    matrix1(2,2) = ', trim(matrix1_c(2,2))
print*, '    matrix1(2,3) = ', trim(matrix1_c(2,3))
print*, ' '
if (trim(matrix1_c(2,3)) /= 'C') isgood=.false.

print*, '(C) character matrix4 will be pasted by E'
print*, '    matrix4(1,3) = ', trim(matrix4_c(1,3))
call paste(matrix4_c, 'E')
print*, '    matrix4(1,4) = ', trim(matrix4_c(1,4))
print*, ' '
if (trim(matrix4_c(1,4)) /= 'E') isgood=.false.

deallocate(matrix1_c, matrix2_c, matrix3_c, matrix4_c)
#endif

if (isgood) then
   write(*,*) 'mo_append ', color('o.k.', c_green)
else
   write(*,*) 'mo_append ', color('failed!', c_red)
endif

END PROGRAM append_test


!> solve (K-z_i.M)x=b, where K and M are real matrices of size ndof,
!> z_i (i=1,...,nsfts) is a complex number. One may have multiple right-hand size.
module module_scocg
  use module_globals
  use module_random_numbers
  implicit none

  type LinearSystems
     integer :: ndof !< DoF
     integer :: nnzm !< Number of non-zero elements in K matrix
     integer :: nnzk !< Number of non-zero elements in M matrix
     integer :: nshfts !< number of shifts
     integer :: nrhs !< number of right-hand sides
     integer,allocatable :: ik(:), jk(:) !< pointers for K matrix
     integer,allocatable :: im(:), jm(:) !< pointers for M matrix
     real(8),allocatable :: kmat(:) !< K matrix
     real(8),allocatable :: mmat(:) !< M matrix
     real(8),allocatable :: fmmat(:) !< M^-1 matrix
     complex(8),allocatable :: amat(:) !< coefficient matrix (for validation)
     complex(8),allocatable :: shfts(:) !< shfts(j): j-th shift
     complex(8),allocatable :: xvec(:,:,:) !< xvec(:,i): i-th/nrhs and j-th/nshfts sol .
     complex(8),allocatable :: bvec(:,:) !< bvec(:,i): i-th right-hand side
  end type LinearSystems

  integer,pointer :: ndof !< DoF
  integer,pointer :: nnzk !< Number of non-zero elements in K matrix
  integer,pointer :: nnzm !< Number of non-zero elements in M matrix
  integer,pointer :: nshfts !< number of shifts
  integer,pointer :: nrhs !< number of right-hand sides
  integer,pointer :: ik(:), jk(:) !< pointers for K matrix
  integer,pointer :: im(:), jm(:) !< pointers for M matrix
  real(8),pointer :: kmat(:) !< K matrix
  real(8),pointer :: mmat(:) !< M matrix
  real(8),pointer :: fmmat(:) !< M^-1 matrix
  complex(8),pointer :: shfts(:) !< shfts(j): j-th shift
  complex(8),pointer :: xvec(:,:,:) !< xvec(:,i,j): i-th/nrhs and j-th/nshfts sol .
  complex(8),pointer :: bvec(:,:) !< bvec(:,i): i-th right-hand side

  ! pardiso
  integer(8) :: pt(64)
  integer :: maxfct, mnum, mtype, phase, error, msglvl
  integer :: iparm(64)
  integer :: i, idum(1)
  real(8) :: ddum(1)

contains

  !> quick sort for ia
  recursive subroutine quicksort(ia,ja,a,first,last)
    implicit none
    integer :: first, last
    integer :: i, j, k, t
    integer :: ia(*), ja(*)
    real(8) :: a(*)
    integer :: l
    real(8) :: cmp

    l=first+last
    k=ia(l/2)
    i=first
    j=last
    do
       do while (ia(i)<k)
          i=i+1
       end do
       do while (k<ia(j))
          j=j-1
       end do
       if (i >= j) exit
       t=ia(i)
       ia(i)=ia(j)
       ia(j)=t
       t=ja(i)
       ja(i)=ja(j)
       ja(j)=t
       cmp=a(i)
       a(i)=a(j)
       a(j)=cmp
       i=i+1
       j=j-1
    end do
    if(first < i-1) call quicksort(ia,ja,a,first,i-1)
    if(j+1 < last)  call quicksort(ia,ja,a,j+1,last)
  end subroutine quicksort

  !> quick sort for ja
  recursive subroutine quicksort2(ia,a,first,last)
    implicit none
    integer :: first, last
    integer :: i, j, k, t
    integer :: ia(*)
    real(8) :: a(*)
    integer :: l
    real(8) :: cmp

    l=first+last
    k=ia(l/2)
    i=first
    j=last
    do
       do while (ia(i)<k)
          i=i+1
       end do
       do while (k<ia(j))
          j=j-1
       end do
       if (i >= j) exit
       t=ia(i)
       ia(i)=ia(j)
       ia(j)=t
       cmp=a(i)
       a(i)=a(j)
       a(j)=cmp
       i=i+1
       j=j-1
    end do
    if(first < i-1) call quicksort2(ia,a,first,i-1)
    if(j+1 < last)  call quicksort2(ia,a,j+1,last)
  end subroutine quicksort2

  !> initialise
  subroutine init_scocg(fk,fm,fs,ls_)
    character(len=32),intent(in) :: fk, fm
    character(len=32),intent(in) :: fs
    type(LinearSystems),intent(inout),target :: ls_

    integer,allocatable :: iia(:)
    integer :: itmp, ix, iy, i
    real(8) :: tmp

    ndof=>ls_%ndof
    nnzk=>ls_%nnzk
    nnzm=>ls_%nnzm
    nshfts=>ls_%nshfts
    nrhs=>ls_%nrhs

    ! load matrix K
    open(1,file=fk)
    read(1,*); read(1,*) ! skip headers
    read(1,*) ndof, itmp, nnzk
    allocate(iia(nnzk))
    allocate(ls_%ik(ndof+1)); ik=>ls_%ik
    allocate(ls_%jk(nnzk)); jk=>ls_%jk
    allocate(ls_%kmat(nnzk)); kmat=>ls_%kmat
    do i=1,nnzk
       read(1,*) ix, iy, tmp
       iia(i)=ix+1
       jk(i)=iy+1
       kmat(i)=tmp
    end do
    close(1)

    call quicksort(iia,jk,kmat,1,nnzk)
    ik(1)=1
    itmp=1
    do i=1,ndof-1
       do while(iia(itmp).eq.i)
          itmp=itmp+1
       end do
       ik(i+1)=itmp
    end do
    ik(ndof+1)=nnzk+1
    do i=1,ndof
       call quicksort2(jk,kmat,ik(i),ik(i+1)-1)
    end do
    deallocate(iia)

    ! load mass matrix M
    open(1,file=fm)
    read(1,*); read(1,*) ! skip headers
    read(1,*) ndof, itmp, nnzm
    allocate(iia(nnzm))
    allocate(ls_%im(ndof+1)); im=>ls_%im
    allocate(ls_%jm(nnzm)); jm=>ls_%jm
    allocate(ls_%mmat(nnzm)); mmat=>ls_%mmat
    allocate(ls_%fmmat(nnzm)); fmmat=>ls_%fmmat
    do i=1,nnzm
       read(1,*) ix, iy, tmp
       iia(i)=ix+1
       jm(i)=iy+1
       mmat(i)=tmp
    end do
    close(1)

    call quicksort(iia,jm,mmat,1,nnzm)
    im(1)=1
    itmp=1
    do i=1,ndof-1
       do while(iia(itmp).eq.i)
          itmp=itmp+1
       end do
       im(i+1)=itmp
    end do
    im(ndof+1)=nnzm+1
    do i=1,ndof
       call quicksort2(jm,mmat,im(i),im(i+1)-1)
    end do
    fmmat=mmat

    deallocate(iia)

    ! load shifts
    open(1,file=fs)
    read(1,*) nshfts
    allocate(ls_%shfts(nshfts)); shfts=>ls_%shfts
    read(1,*) shfts
    close(1)

    ! right-hand sides
    nrhs=20
    allocate(ls_%bvec(ndof,nrhs)); bvec=>ls_%bvec
    allocate(ls_%xvec(ndof,nshfts,nrhs)); xvec=>ls_%xvec

    call gen_random_numbers_complex(ndof*nrhs,bvec)

  end subroutine init_scocg

  !> destroy
  subroutine uninit_scocg(ls_)
    type(LinearSystems),intent(inout),target :: ls_

    nullify(ndof,nnzk,nnzm,nshfts,nrhs)
    deallocate(ls_%ik,ls_%jk,ls_%kmat,ls_%im,ls_%jm,ls_%mmat,ls_%fmmat,ls_%shfts)
    nullify(ik,jk,im,jk,kmat,mmat,fmmat,shfts)
    deallocate(ls_%bvec,ls_%xvec)
    nullify(bvec,xvec)

  end subroutine uninit_scocg

  subroutine lapack_complex
    integer :: i, j

    integer :: k, icnt, info, ipiv(ndof)
    complex(8),allocatable :: am(:,:)

    allocate(am(ndof,ndof))

    do i=1,nshfts
       am(:,:)=zero
       icnt=1
       do j=1,ndof
          do k=ik(j),ik(j+1)-1
             am(j,jk(icnt))=kmat(icnt)
             icnt=icnt+1
          end do
       end do
       icnt=1
       do j=1,ndof
          do k=im(j),im(j+1)-1
             am(j,jm(icnt))=am(j,jm(icnt))-shfts(i)*mmat(icnt)
             icnt=icnt+1
          end do
       end do
       xvec(:,i,:)=bvec
       call zgesv(ndof,nrhs,am,ndof,ipiv,xvec(:,i,:),ndof,info)
       do j=1,ndof
          write(9+i,*) real(xvec(j,i,3)), aimag(xvec(j,i,3))
       end do
    end do
    deallocate(am)

  end subroutine lapack_complex

  !> the main
  subroutine scocg
    integer :: irhs, ishf, ist, i, j, k, icnt
    real(8) :: tvecr(ndof,2*nrhs), qvecr(ndof,2*nrhs)
    complex(8) :: pvec(ndof,nshfts,nrhs), rvec(ndof,nrhs), tvec(ndof,nrhs), qvec(ndof,nrhs)
    complex(8) :: alp(2,nshfts,nrhs), bet(2,nshfts,nrhs), c(3,nshfts,nrhs) !!!!!!!!!!!!

    complex(8) :: bunbo(nrhs), bunsi(nrhs), sig
    logical :: chk

    integer :: itgv(ndof)

    itgv(:)=1
    icnt=1
    do i=1,ndof
       do k=ik(i),ik(i+1)-1
          if(kmat(icnt).gt.1.d+20) itgv(i)=0
          icnt=icnt+1
       end do
    end do

    ! precon. invert M
    maxfct = 1
    mnum = 1
    iparm(:)=0
    iparm(1) = 1 ! no solver default
    iparm(2) = 2 ! fill-in reordering from METIS
    iparm(4) = 0 ! no iterative-direct algorithm
    iparm(5) = 0 ! no user fill-in reducing permutation
    iparm(6) = 0 ! =0 solution on the first n components of x
    iparm(8) = 0 ! numbers of iterative refinement steps
    iparm(10) = 13 ! perturb the pivot elements with 1E-13
    iparm(11) = 1 ! use nonsymmetric permutation and scaling MPS
    iparm(13) = 0 ! maximum weighted matching algorithm is switched-off (default for symmetric). Try iparm(13) = 1 in case of inappropriate accuracy
    iparm(14) = 0 ! Output: number of perturbed pivots
    iparm(18) = 1 ! Output: number of nonzeros in the factor LU
    iparm(19) = 1 ! Output: Mflops for LU factorization
    iparm(20) = 0 ! Output: Numbers of CG Iterations

    error  = 0 ! initialize error flag
    msglvl = 0 ! print statistical information
    mtype  = 11 ! real, general

    pt(:)=0

    ! factorise M
    phase=12 ! Analysis, numerical factorization
    call pardiso (pt, maxfct, mnum, mtype, phase, ndof, fmmat, im, jm, &
         idum, 1, iparm, msglvl, ddum, ddum, error)
    if (error /= 0) then
       write(*,*) 'The following ERROR was detected: ', error
       stop
    end if

    ! q=M^-1.b
    do irhs=1,nrhs
       tvecr(:,2*irhs-1)= real(bvec(:,irhs))
       tvecr(:,2*irhs  )=aimag(bvec(:,irhs))
    end do
    qvecr(:,:)=zero
    phase=33
    call pardiso (pt, maxfct, mnum, mtype, phase, ndof, fmmat, im, jm, &
         idum, 2*nrhs, iparm, msglvl, tvecr, qvecr, error)
    if (error /= 0) then
       write(*,*) 'the following error was detected (doko): ', error
       stop
    endif
    do irhs=1,nrhs
       qvec(:,irhs)=cmplx(qvecr(:,2*irhs-1),qvecr(:,2*irhs),kind(1.d0))*itgv(:)
    end do

    ! initialise
    do irhs=1,nrhs
       rvec(:,irhs)=bvec(:,irhs)*itgv(:)
    end do
    do ishf=1,nshfts
       pvec(:,ishf,:)=qvec(:,:)
       xvec(:,ishf,:)=zero
    end do

    c(:,:,:)=one
    alp(:,:,:)=one
    bet(:,:,:)=zero

    ! CG loop
    do ist=1,ndof

       ! bunsi=r^t.M^-1r=r^t.q
       bunsi(:)=zero
       do j=1,ndof
          bunsi(:)=bunsi(:)+rvec(j,:)*qvec(j,:)
       end do

       ! t=(K-z0.M)p
       tvec(:,:)=zero
       icnt=1
       do i=1,ndof
          do k=ik(i),ik(i+1)-1
             tvec(i,:)=tvec(i,:)+kmat(icnt)*pvec(jk(icnt),1,:)
             icnt=icnt+1
          end do
       end do
       icnt=1
       do i=1,ndof
          do k=im(i),im(i+1)-1
             tvec(i,:)=tvec(i,:)-shfts(1)*mmat(icnt)*pvec(jm(icnt),1,:)
             icnt=icnt+1
          end do
       end do

       ! bunbo=p^t.(M^-1.K)p
       bunbo(:)=zero
       do j=1,ndof
          bunbo(:)=bunbo(:)+pvec(j,1,:)*tvec(j,:)
          !write(101,*) pvec(j,1)
       end do

       ! update alpha
       alp(2,1,:)=alp(1,1,:) ! keep the previous one
       alp(1,1,:)=bunsi(:)/bunbo(:) ! and update
       do irhs=1,nrhs
          xvec(:,1,irhs)=xvec(:,1,irhs)+alp(1,1,irhs)*pvec(:,1,irhs)
       end do

       ! update rvec
       do irhs=1,nrhs
          rvec(:,irhs)=rvec(:,irhs)-alp(1,1,irhs)*tvec(:,irhs)
          rvec(:,irhs)=rvec(:,irhs)*itgv(:)
       end do

       ! update beta
       bunbo(:)=bunsi(:) !beta's bunbo = alpha's bunsi

       ! q=M^-1.r
       do irhs=1,nrhs
          tvecr(:,2*irhs-1)= real(rvec(:,irhs))
          tvecr(:,2*irhs  )=aimag(rvec(:,irhs))
       end do
       qvecr(:,:)=zero
       phase=33
       call pardiso (pt, maxfct, mnum, mtype, phase, ndof, fmmat, im, jm, &
            idum, 2*nrhs, iparm, msglvl, tvecr, qvecr, error)
       if (error /= 0) then
          write(*,*) 'the following error was detected (doko): ', error
          stop
       endif
       do irhs=1,nrhs
          qvec(:,irhs)=cmplx(qvecr(:,2*irhs-1),qvecr(:,2*irhs),kind(1.d0))*itgv(:)
       end do

       ! bunsi=r^t(M^-1.r)=r^t q
       bunsi(:)=zero
       do j=1,ndof
          bunsi(:)=bunsi(:)+rvec(j,:)*qvec(j,:)
       end do
       bet(2,1,:)=bet(1,1,:)
       bet(1,1,:)=bunsi(:)/bunbo(:)

       do irhs=1,nrhs
          pvec(:,1,irhs)=qvec(:,irhs)+bet(1,1,irhs)*pvec(:,1,irhs)
       end do

       do ishf=2,nshfts
          sig=shfts(1)-shfts(ishf)
          c(3,ishf,:)=c(2,ishf,:)
          c(2,ishf,:)=c(1,ishf,:)
          c(1,ishf,:)=(1.d0+alp(1,1,:)*sig)*c(2,ishf,:)&
               +(c(2,ishf,:)-c(3,ishf,:))*bet(2,1,:)*alp(1,1,:)/alp(2,1,:)
          alp(1,ishf,:)=c(2,ishf,:)/c(1,ishf,:)*alp(1,1,:)
          bet(1,ishf,:)=(c(2,ishf,:)/c(1,ishf,:))**2*bet(1,1,:)
          do irhs=1,nrhs
             xvec(:,ishf,irhs)=xvec(:,ishf,irhs)+alp(1,ishf,irhs)*pvec(:,ishf,irhs)
             pvec(:,ishf,irhs)=qvec(:,irhs)/c(1,ishf,irhs)+bet(1,ishf,irhs)*pvec(:,ishf,irhs)
          end do
       end do
       chk=.true.
       do irhs=1,nrhs
          chk=chk&
               .and.(real(dot_product(rvec(:,irhs),rvec(:,irhs)))&
               .le.real(dot_product(bvec(:,irhs),bvec(:,irhs)))*1.d-16)
       end do
       write(*,*) ist
       if(chk) exit
    end do

    do i=1,nshfts
       do j=1,ndof
          write(29+i,*) real(xvec(j,i,3)), aimag(xvec(j,i,3))
       end do
    end do

  end subroutine scocg

end module module_scocg


PROGRAM testdrop

  USE mod_prec
  USE moa, ONLY: moa_drop
  IMPLICIT NONE

  INTEGER, PARAMETER :: n = 10
  INTEGER :: i, sigma
  REAL, TARGET :: v(0:n-1)
  REAL, POINTER :: ptr_r(:)

  ! Initialize vector
  v = [( 0.1 * REAL(i), i = 0, n-1 )]
  PRINT *, 'vvec = '
  PRINT *, ( v(i), ' ' , i = 0, n-1 )

  ! Test error messages
  PRINT *, 'Test error message for positive overdrop'
  ptr_r => moa_drop( 12, v )
  PRINT *

  PRINT *, 'Test error message for negative overtake'
  ptr_r => moa_drop( -12, v )
  PRINT *

  ! Test positive drop
  sigma = 2
  ptr_r => moa_drop( sigma, v )
  PRINT *, sigma, ' drop vvec = '
  PRINT *, ( ptr_r(i), ' ' , i = 1, n-sigma )
  PRINT *
  NULLIFY(ptr_r)

  ! Test negative take
  sigma = -2
  ptr_r => moa_drop( sigma, v )
  PRINT *, sigma, ' drop vvec = '
  PRINT *, ( ptr_r(i), ' ' , i = 1, n-ABS(sigma) )
  NULLIFY(ptr_r)

  STOP
END PROGRAM testdrop


program test

  real :: a(3)
  real :: sq = 9

  a(1) = 1.0
  a(2) = 2.0
  a(3) = 4.0

  a = sqrt(sq) * a
  print *, a

end program


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR DOPRI5 ON VAN DER POL'S EQUATION
C * * * * * * * * * * * * * * * * * * * * * * * * *
cfeh dr_dop853 dop853
        IMPLICIT REAL*8 (A-H,O-Z)
        PARAMETER (NDGL=2,NRD=2)
        PARAMETER (LWORK=11*NDGL+8*NRD+21,LIWORK=NRD+21)
        DIMENSION Y(NDGL),WORK(LWORK),IWORK(LIWORK)
        EXTERNAL FVPOL,SOLOUT
C --- DIMENSION OF THE SYSTEM
        N=2
        RPAR=1.0D-3
C --- OUTPUT ROUTINE (AND DENSE OUTPUT) IS USED DURING INTEGRATION
        IOUT=2
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=2.0D0
        Y(2)=0.0D0
C --- ENDPOINT OF INTEGRATION
        XEND=2.0D0
C --- REQUIRED (RELATIVE) TOLERANCE
        TOL=1.0D-9
        ITOL=0
        RTOL=TOL
        ATOL=TOL
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,10
        IWORK(I)=0
  10    WORK(I)=0.D0
        IWORK(5)=N
        IWORK(4)=1
C --- CALL OF THE SUBROUTINE DOPRI8
        CALL DOP853(N,FVPOL,X,Y,XEND,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT FINAL SOLUTION
        WRITE (6,99) X,Y(1),Y(2)
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10)
C --- PRINT STATISTICS
        WRITE (6,90) TOL
 90     FORMAT('       tol=',D8.2)
        WRITE (6,91) (IWORK(J),J=17,20)
 91     FORMAT(' fcn=',I5,' step=',I4,' accpt=',I4,' rejct=',I3)
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,CON,ICOMP,ND,RPAR,IPAR,IRTRN)
C --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
C --- BY USING "CONTD8", THE CONTINUOUS COLLOCATION SOLUTION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CON(8*ND),ICOMP(ND)
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=X+0.1D0
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) XOUT,CONTD8(1,XOUT,CON,ICOMP,ND),
     &                     CONTD8(2,XOUT,CON,ICOMP,ND),NR-1
              XOUT=XOUT+0.1D0
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END
C
        SUBROUTINE FVPOL(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF VAN DER POL'S EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        EPS=RPAR
        F(1)=Y(2)
        F(2)=((1-Y(1)**2)*Y(2)-Y(1))/EPS
        RETURN
        END


c###genion.for
      SUBROUTINE GENION(K)
C--------------------------------
C  THIS SECTION WILL GENERATE AN ELECTRON DENSITY PROFILE, AN IONOGRAM,
C  A REFLECTRIX,TABLE OF OBLIQUE FREQUENCIES AND DISTANCES AT SPECIFIED
C  ANGLES,ORDINARY MODE ONLY
C
C     HTR(50,3)  TRUE HEIGHT PROFILE FOR ELECTRON DENSITY PROFILE -- KM
C     FNSQ(50,3) ELECTRON DENSITY AS PLASMA FREQUENCY -- (MHZ)**2
C     FVERT(30,5) VERTICAL SOUNDING FREQUENCY--MHZ
C     HTRUE(30,5) TRUE HEIGHT OF REFLECTION--KM
C     HPRIM(30,5) VIRTUAL HEIGHT OF REFLECTION--KM
C
C     IFOB(40,30,5) OBLIQUE OPERATING FREQUENCY -- HZ
C     IDIST(40,30,5) PATH DISTANCE -- KM
C     ANG(40)  ELEVATION ANGLE -- DEGREES
C
      COMMON / MFAC / F2M3(5),HPF2(5),ZENANG(5),ZENMAX(5),IEDP,FSECV(3)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      DIMENSION HTE(10),HPE(10)
C.....TRUE AND VIRTUAL HEIGHTS FOR E LAYER WITH 110 AND 20 AS PARAMETERS
      DATA HTE/70.00,84.51,88.52,93.00,94.26,95.71,97.68,100.27,104.22,
     A 107.19 /
      DATA HPE/70.00,87.40,94.00,98.68,100.20,102.65,107.15,113.74,
     A 125.25,140.03/
C  SAMPLE VERTICAL SOUNDING  FREQUENCIES
C D-E  REGION TAIL
C   XTAIL MUST AGREE WITH LECDEN
      XTAIL = .85
      FEX = FI(1,K) * SQRT(1. - XTAIL * XTAIL)
      FVERT (1, K) = .01
      FVERT (4, K) = FEX
      FDIF = (FVERT (4, K) - FVERT (1, K)) / 3.
      FVERT (2, K) = FVERT (1, K) + FDIF
      FVERT (3, K) = FVERT (2, K) + FDIF
C  E REGION NOSE
C.....GUESS FOR E MUF
      FVERT(9,K) = .957 * FI(1,K)
      FVERT(10,K) = 0.99 * FI(1,K)
      FDIF = (FVERT(9,K) - FVERT(4,K)) / 5.
      FVERT (5, K) = FVERT (4, K) + FDIF
      FVERT (6, K) = FVERT (5, K) + FDIF
      FVERT (7, K) = FVERT (6, K) + FDIF
      FVERT (8, K) = FVERT (7, K) + FDIF
C.....E - F CUSP
      FVERT(11,K) =  1.05 * FI(1,K)
C.....F REGION NOSE
      FVERT(30,K) = 0.99 * FI(3,K)
      FVERT (29, K) = 0.98 * FI (3, K)
      FVERT (28, K) = 0.96 * FI (3, K)
      FVERT (27, K) = 0.92 * FI (3, K)
      IF (FI (2, K))385, 385, 400
C   F2 LAYER, NO F1 LAYER
  385 CONTINUE
      FDIF = (FVERT (27, K) - FVERT (11, K)) / 16.
      DO 395 IF = 12, 26
  395 FVERT (IF, K) = FVERT (IF - 1, K) + FDIF
      GO TO 425
C  F1 LAYER  AND F2 LAYER
  400 CONTINUE
      FVERT(20,K) = 0.99 * FI(2,K)
      FDIF = (FVERT (20, K) - FVERT (11, K)) / 9.
      DO 405 IF = 12, 19
  405 FVERT (IF, K) = FVERT (IF - 1, K) + FDIF
C.....F1 - F2 CUSP
      FVERT(21,K) = 1.01 * FI(2,K)
      FDIF = (FVERT (27, K) - FVERT (21, K)) / 6.
      DO 415 IF = 22, 26
  415 FVERT (IF, K) = FVERT (IF - 1, K) + FDIF
  425 CONTINUE
C.....DO FAST VERSION INTEGRATION BY DEFAULT
      IF( IEDP ) 600,705,705
  600 CONTINUE
C
C
C   INTEGRATE TO GET IONOGRAM,  NT-POINT GUASSIAN
C
      DO 640 IF = 1, 30
C.....VERTICAL SOUNDING FREQUENCY
      FXX = FVERT(IF,K)
      CALL GETHP(FXX, HPX, HTX)
C.....HPRIM(IF,K) IS THE VIRTUAL HEIGHT
C.....HTRUE(IF,K) IS THE TRUE HEIGHT
      HPRIM(IF,K) = HPX
      HTRUE(IF,K) = HTX
  640 CONTINUE
      GO TO 750
  705 CONTINUE
C
C FASTER VERSION, PARABOLIC E LAYER ( HI(1,K)=110.,YI(1,K)=20.) WITH
C  EXPONENTIAL TAIL.
C
C.....SAME AS CALL TO SUBROUTINE GETHP FOR DEFAULT E LAYER
      DO 710 IF = 1,10
      HTRUE(IF,K) = HTE(IF)
      HPRIM(IF,K) = HPE(IF)
710   continue
      DO 715 IF = 11,30
      FN = FVERT(IF,K)*FVERT(IF,K)
C.....TRUE HEIGHT BY TABLE LOOKUP
      HTRUE(IF,K) = XLIN(FN,FNSQ(1,1),HTR(1,1),50,1 )
  715 CONTINUE
      IF( FI(2,K) ) 720,720,730
  720 CONTINUE
      DO 725 IF = 11,30
C.....BOTTOM OF F LAYER PLUS BENDING PLUS RETARDATION
      FN = FVERT(IF,K)
      HPRIM(IF,K) = HI(3,K) - YI(3,K) + BENDY(3,K,FN)
     A            + (PEN(1,K,FN) - 2.*YI(1,K) )
  725 CONTINUE
      GO TO 750
  730 CONTINUE
C.....THERE ARE TO MANY POSSIBILITIES WITH F1 PRESENT
      DO 740 IF = 11,30
      FXX = FVERT(IF,K)
      CALL GETHP(FXX,HPX,HTX)
      HPRIM(IF,K) = HPX
  740 CONTINUE
  750 CONTINUE
      RETURN
      END
C--------------------------------