!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This is the FFTPACK5 implementation of the FFT library

! Note this engine code has been modified to suit the packaging of
! FFTPACK 5.1 where single- and double-precision routines are pack
! in separate files but using the same symbols. The preprocessing
! branches for precisions remain, in case the packaging is changed
! to the old way, that rename double-precision routines (c->z; r->d).
!
! Do not use the 5.0 version as it contains serious bugs and gives
! incorrect results for transform sizes with large prime numbers.
! http://people.sc.fsu.edu/~jburkardt/f_src/fftpack5.1/fftpack5.1.html

module decomp_2d_fft

  use decomp_2d  ! 2D decomposition module

  implicit none

  private        ! Make everything private unless declared public

  ! engine-specific global variables

  ! FFTPACK work arrays
  complex(mytype), allocatable, dimension(:) :: wsave, work
  integer, save :: lensav, lenwrk

  ! work arrays to save intermediate 1D data sets
  complex(mytype), allocatable, dimension(:) :: buf_c
  real   (mytype), allocatable, dimension(:) :: buf_r

  ! common code used for all engines, including global variables,
  ! generic interface definitions and several subroutines
#include "fft_common.f90"

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time initialisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_fft_engine

    implicit none

    integer :: maxdim

    if (nrank==0) then
       write(*,*) ' '
       write(*,*) '***** Using the FFTPACK5 engine *****'
       write(*,*) ' '
    end if

    maxdim = max(ph%xsz(1),max(ph%ysz(2),ph%zsz(3)))
    lensav = 2*maxdim + int(log(real(maxdim))/log(2.)) + 4
    lenwrk = 2*maxdim

    allocate(wsave(lensav))
    allocate(work(lenwrk))
    allocate(buf_c(maxdim))

    if (format==PHYSICAL_IN_X) then
       allocate(buf_r(ph%xsz(1)))
    else if(format==PHYSICAL_IN_Z) then
       allocate(buf_r(ph%zsz(3)))
    end if

    return
  end subroutine init_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time finalisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine finalize_fft_engine

    implicit none

    deallocate(wsave, work, buf_c, buf_r)

    return
  end subroutine finalize_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D FFT - complex to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2c(in, out, isign)

    implicit none

    complex(mytype), dimension(:,:,:), intent(IN) :: in
    complex(mytype), dimension(:,:,:), intent(OUT) :: out
    integer, intent(IN) :: isign

    complex(mytype), allocatable, dimension(:,:,:) :: wk1
    integer :: i,j,k, ier

    if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR.  &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then

       ! ===== 1D FFTs in X =====
       allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
#ifdef DOUBLE_PREC
       call cfft1i(ph%xsz(1), wsave, lensav, ier)
#else
       call cfft1i(ph%xsz(1), wsave, lensav, ier)
#endif
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
             do i=1,ph%xsz(1)
                buf_c(i) = in(i,j,k)
             enddo
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             end if
             do i=1,ph%xsz(1)
                wk1(i,j,k) = buf_c(i)
             end do
          end do
       end do

       ! ===== Swap X --> Y =====
       call transpose_x_to_y(wk1,wk2_c2c,ph)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(ph%ysz(2), wsave, lensav, ier)
#else
       call cfft1i(ph%ysz(2), wsave, lensav, ier)
#endif
       do k=1,ph%ysz(3)
          do i=1,ph%ysz(1)
             do j=1,ph%ysz(2)
                buf_c(j) = wk2_c2c(i,j,k)
             end do
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             end if
             do j=1,ph%ysz(2)
                wk2_c2c(i,j,k) = buf_c(j)
             end do
          end do
       end do

       ! ===== Swap Y --> Z =====
       call transpose_y_to_z(wk2_c2c,out,ph)

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call cfft1i(ph%zsz(3), wsave, lensav, ier)
#else
       call cfft1i(ph%zsz(3), wsave, lensav, ier)
#endif
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             do k=1,ph%zsz(3)
                buf_c(k) = out(i,j,k)
             end do
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             end if
             do k=1,ph%zsz(3)
                out(i,j,k) = buf_c(k)
             end do
          end do
       end do

    else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
         .OR. &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then

       ! ===== 1D FFTs in Z =====
       allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
#ifdef DOUBLE_PREC
       call cfft1i(ph%zsz(3), wsave, lensav, ier)
#else
       call cfft1i(ph%zsz(3), wsave, lensav, ier)
#endif
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             do k=1,ph%zsz(3)
                buf_c(k) = in(i,j,k)
             end do
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%zsz(3),1,buf_c,ph%zsz(3), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             endif
             do k=1,ph%zsz(3)
                wk1(i,j,k) = buf_c(k)
             end do
          end do
       end do

       ! ===== Swap Z --> Y =====
       call transpose_z_to_y(wk1,wk2_c2c,ph)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(ph%ysz(2), wsave, lensav, ier)
#else
       call cfft1i(ph%ysz(2), wsave, lensav, ier)
#endif
       do k=1,ph%ysz(3)
          do i=1,ph%ysz(1)
             do j=1,ph%ysz(2)
                buf_c(j) = wk2_c2c(i,j,k)
             end do
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%ysz(2),1,buf_c,ph%ysz(2), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             endif
             do j=1,ph%ysz(2)
                wk2_c2c(i,j,k) = buf_c(j)
             end do
          end do
       end do

       ! ===== Swap Y --> X =====
       call transpose_y_to_x(wk2_c2c,out,ph)

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call cfft1i(ph%xsz(1), wsave, lensav, ier)
#else
       call cfft1i(ph%xsz(1), wsave, lensav, ier)
#endif
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
             do i=1,ph%xsz(1)
                buf_c(i) = out(i,j,k)
             enddo
             if (isign==DECOMP_2D_FFT_FORWARD) then
#ifdef DOUBLE_PREC
                call cfft1f(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1f(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             else
#ifdef DOUBLE_PREC
                call cfft1b(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#else
                call cfft1b(ph%xsz(1),1,buf_c,ph%xsz(1), &
                     wsave,lensav,work,lenwrk,ier)
#endif
             endif
             do i=1,ph%xsz(1)
                out(i,j,k) = buf_c(i)
             end do
          end do
       end do

    end if

    ! Undo the scaling done in the forward FFTs by the FFT engine
    if (isign==DECOMP_2D_FFT_FORWARD) then
       out = out * real(nx_global, kind=mytype) * &
            real(ny_global, kind=mytype) * &
            real(nz_global, kind=mytype)
    end if

    return
  end subroutine fft_3d_c2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D forward FFT - real to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_r2c(in_r, out_c)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c

    integer :: i,j,k, ier

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call rfft1i(ph%xsz(1),wsave,lensav,ier)
#else
       call rfft1i(ph%xsz(1),wsave,lensav,ier)
#endif
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
             do i=1,ph%xsz(1)
                buf_r(i) = in_r(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call rfft1f(ph%xsz(1),1,buf_r,ph%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call rfft1f(ph%xsz(1),1,buf_r,ph%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             ! convert to complex array of size N/2+1
             call to_complex(buf_r, ph%xsz(1), wk13(:,j,k))
          end do
       end do

       ! ===== Swap X --> Y =====
       call transpose_x_to_y(wk13,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%ysz(2), wsave, lensav, ier)
#else
       call cfft1i(sp%ysz(2), wsave, lensav, ier)
#endif
       do k=1,sp%ysz(3)
          do i=1,sp%ysz(1)
             do j=1,sp%ysz(2)
                buf_c(j) = wk2_r2c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1f(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1f(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do j=1,sp%ysz(2)
                ! also remove the scaling here
                wk2_r2c(i,j,k) = buf_c(j) * real(sp%ysz(2), kind=mytype)
             end do
          end do
       end do

       ! ===== Swap Y --> Z =====
       call transpose_y_to_z(wk2_r2c,out_c,sp)

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%zsz(3), wsave, lensav, ier)
#else
       call cfft1i(sp%zsz(3), wsave, lensav, ier)
#endif
       do j=1,sp%zsz(2)
          do i=1,sp%zsz(1)
             do k=1,sp%zsz(3)
                buf_c(k) = out_c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1f(sp%zsz(3),1,buf_c,sp%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1f(sp%zsz(3),1,buf_c,sp%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do k=1,sp%zsz(3)
                ! also remove the scaling here
                out_c(i,j,k) = buf_c(k) * real(sp%zsz(3), kind=mytype)
             end do
          end do
       end do

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call rfft1i(ph%zsz(3),wsave,lensav,ier)
#else
       call rfft1i(ph%zsz(3),wsave,lensav,ier)
#endif
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             do k=1,ph%zsz(3)
                buf_r(k) = in_r(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call rfft1f(ph%zsz(3),1,buf_r,ph%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call rfft1f(ph%zsz(3),1,buf_r,ph%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             ! convert to complex array of size N/2+1
             ! note the use of temp array here,
             ! cannot write directly into wk13 because of stride
             call to_complex(buf_r, ph%zsz(3), buf_c)
             do k=1,sp%zsz(3)
                wk13(i,j,k) = buf_c(k)
             end do
          end do
       end do

       ! ===== Swap Z --> Y =====
       call transpose_z_to_y(wk13,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%ysz(2), wsave, lensav, ier)
#else
       call cfft1i(sp%ysz(2), wsave, lensav, ier)
#endif
       do k=1,sp%ysz(3)
          do i=1,sp%ysz(1)
             do j=1,sp%ysz(2)
                buf_c(j) = wk2_r2c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1f(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1f(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do j=1,sp%ysz(2)
                ! also remove the scaling here
                wk2_r2c(i,j,k) = buf_c(j) * real(sp%ysz(2), kind=mytype)
             end do
          end do
       end do

       ! ===== Swap Y --> X =====
       call transpose_y_to_x(wk2_r2c,out_c,sp)

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%xsz(1), wsave, lensav, ier)
#else
       call cfft1i(sp%xsz(1), wsave, lensav, ier)
#endif
       do k=1,sp%xsz(3)
          do j=1,sp%xsz(2)
             do i=1,sp%xsz(1)
                buf_c(i) = out_c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1f(sp%xsz(1),1,buf_c,sp%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1f(sp%xsz(1),1,buf_c,sp%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do i=1,sp%xsz(1)
                ! also remove the scaling here
                out_c(i,j,k) = buf_c(i) * real(sp%xsz(1), kind=mytype)
             end do
          end do
       end do

    end if

    return
  end subroutine fft_3d_r2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D inverse FFT - complex to real
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2r(in_c, out_r)

    implicit none

    complex(mytype), dimension(:,:,:), intent(IN) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r

    complex(mytype), allocatable, dimension(:,:,:) :: wk1
    integer :: i,j,k, ier

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in Z =====
       allocate (wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
#ifdef DOUBLE_PREC
       call cfft1i(sp%zsz(3),wsave,lensav,ier)
#else
       call cfft1i(sp%zsz(3),wsave,lensav,ier)
#endif
       do j=1,sp%zsz(2)
          do i=1,sp%zsz(1)
             do k=1,sp%zsz(3)
                buf_c(k) = in_c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1b(sp%zsz(3),1,buf_c,sp%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1b(sp%zsz(3),1,buf_c,sp%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do k=1,sp%zsz(3)
                wk1(i,j,k) = buf_c(k)
             end do
          end do
       end do

       ! ===== Swap Z --> Y =====
       call transpose_z_to_y(wk1,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%ysz(2),wsave,lensav,ier)
#else
       call cfft1i(sp%ysz(2),wsave,lensav,ier)
#endif
       do k=1,sp%ysz(3)
          do i=1,sp%ysz(1)
             do j=1,sp%ysz(2)
                buf_c(j) = wk2_r2c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1b(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1b(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do j=1,sp%ysz(2)
                wk2_r2c(i,j,k) = buf_c(j)
             end do
          end do
       end do

       ! ===== Swap Y --> X =====
       call transpose_y_to_x(wk2_r2c,wk13,sp)

       ! ===== 1D FFTs in X =====
#ifdef DOUBLE_PREC
       call rfft1i(ph%xsz(1),wsave,lensav,ier)
#else
       call rfft1i(ph%xsz(1),wsave,lensav,ier)
#endif
       do k=1,ph%xsz(3)
          do j=1,ph%xsz(2)
             call from_complex(wk13(:,j,k), ph%xsz(1), buf_r)
#ifdef DOUBLE_PREC
             call rfft1b(ph%xsz(1),1,buf_r,ph%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call rfft1b(ph%xsz(1),1,buf_r,ph%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do i=1,ph%xsz(1)
                out_r(i,j,k) = buf_r(i)
             end do
          end do
       end do

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in X =====
       allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
#ifdef DOUBLE_PREC
       call cfft1i(sp%xsz(1),wsave,lensav,ier)
#else
       call cfft1i(sp%xsz(1),wsave,lensav,ier)
#endif
       do k=1,sp%xsz(3)
          do j=1,sp%xsz(2)
             do i=1,sp%xsz(1)
                buf_c(i) = in_c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1b(sp%xsz(1),1,buf_c,sp%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1b(sp%xsz(1),1,buf_c,sp%xsz(1), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do i=1,sp%xsz(1)
                wk1(i,j,k) = buf_c(i)
             end do
          end do
       end do

       ! ===== Swap X --> Y =====
       call transpose_x_to_y(wk1,wk2_r2c,sp)

       ! ===== 1D FFTs in Y =====
#ifdef DOUBLE_PREC
       call cfft1i(sp%ysz(2),wsave,lensav,ier)
#else
       call cfft1i(sp%ysz(2),wsave,lensav,ier)
#endif
       do k=1,sp%ysz(3)
          do i=1,sp%ysz(1)
             do j=1,sp%ysz(2)
                buf_c(j) = wk2_r2c(i,j,k)
             end do
#ifdef DOUBLE_PREC
             call cfft1b(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call cfft1b(sp%ysz(2),1,buf_c,sp%ysz(2), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do j=1,sp%ysz(2)
                wk2_r2c(i,j,k) = buf_c(j)
             end do
          end do
       end do

       ! ===== Swap Y --> Z =====
       call transpose_y_to_z(wk2_r2c,wk13,sp)

       ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
       call rfft1i(ph%zsz(3),wsave,lensav,ier)
#else
       call rfft1i(ph%zsz(3),wsave,lensav,ier)
#endif
       do j=1,ph%zsz(2)
          do i=1,ph%zsz(1)
             do k=1,sp%zsz(3)
                buf_c(k) = wk13(i,j,k)
             end do
             call from_complex(buf_c, ph%zsz(3), buf_r)
#ifdef DOUBLE_PREC
             call rfft1b(ph%zsz(3),1,buf_r,ph%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#else
             call rfft1b(ph%zsz(3),1,buf_r,ph%zsz(3), &
                  wsave,lensav,work,lenwrk,ier)
#endif
             do k=1,ph%zsz(3)
                out_r(i,j,k) = buf_r(k)
             end do
          end do
       end do

    end if

    return
  end subroutine fft_3d_c2r

  ! Two utility routines to convert internal storage format

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Rearrange data to half-plus-1-complex-storage format
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine to_complex(in,n,out)

    implicit none

    integer, intent(IN) :: n
    real(mytype), dimension(0:n-1), intent(IN) :: in
    complex(mytype), dimension(0:n/2), intent(OUT) :: out

    integer :: i

    ! From FFTPACK5's document, the 1D r2c result is returned in the
    ! same real input array and the storage format appears to be:
    !   -- a real number:  0th result (real by definition)
    !   -- real part and imaginary part of complex numbers
    !   -- another real number for the (N/2)th result, if N is even
    ! Also all complex numbers appear to have a factor of 2 in them.

    out(0) = cmplx(in(0), 0._mytype, kind=mytype)

    if (n == n/2*2) then ! n is even
       do i=1,n/2-1
          out(i) = cmplx(in(2*i-1)*0.5_mytype, -in(2*i)*0.5_mytype, &
               kind=mytype)
       end do
       out(n/2) = cmplx(in(n-1), 0._mytype, kind=mytype)
    else                 ! n is odd
       do i=1,n/2
          out(i) = cmplx(in(2*i-1)*0.5_mytype, -in(2*i)*0.5_mytype, &
               kind=mytype)
       end do
    end if

    ! also remove the scaling as we need unscaled 1D FFT
    out = out * real(n, kind=mytype)

    return
  end subroutine to_complex

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! The opposite of the above
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine from_complex(in,n,out)

    implicit none

    integer, intent(IN) :: n
    complex(mytype), dimension(0:n/2), intent(IN) :: in
    real(mytype), dimension(0:n-1), intent(OUT) :: out

    integer :: i

    out(0) = real(in(0), kind=mytype)

    if (n == n/2*2) then ! n is even
       do i=1,n/2-1
          out(2*i-1) = real(in(i), kind=mytype)*2.0_mytype
          out(2*i)   = -aimag(in(i))*2.0_mytype
       end do
       out(n-1) = real(in(n/2), kind=mytype)
    else                 ! n is odd
       do i=1,n/2
          out(2*i-1) = real(in(i), kind=mytype)*2.0_mytype
          out(2*i)   = -aimag(in(i))*2.0_mytype
       end do
    end if

    return
  end subroutine from_complex

end module decomp_2d_fft


      double complex function qllnomrat4(ms1,ms2,mt1,mt2)
************************************************************************
*     Author: R.K. Ellis                                               *
*     August, 2007.                                                    *
*     Lnomrat4(-s1,-s2,-t1,-t2)=                                       *
*     ln(1-((ms1-i*ep)*(ms2-i*ep))/((mt1-i*ep)/(mt2-i*ep)))            *
*     this function is hard-wired for sign of epsilon we must adjust   *
*     sign of s1,s2,t1,t2 to get the right sign for epsilon            *
************************************************************************
      implicit none
      include 'qlconstants.f'
      double precision ms1,ms2,mt1,mt2,prod,htheta
C--- define Heaviside theta function (=1 for x>0) and (0 for x < 0)
      htheta(ms1)=half+half*sign(one,ms1)
      prod=1d0-(ms1*ms2)/(mt1*mt2)
      qllnomrat4=dcmplx(dlog(abs(prod)))
     . -half*impi*dcmplx(htheta(-prod))
     . *dcmplx(htheta(-ms1)+htheta(-ms2)-htheta(-mt1)-htheta(-mt2))

      return
      end


      subroutine qlbox10(Y,musq,Ires)
      implicit none
C  I^{\{D=4-2 \epsilon\}}_4(0,p_2^2,p_3^2,p_4^2;s_{12},s_{23};0,0,0,m^2)

c                  [                            s12     msq - p4sq ]
c                  [     0           0        - ---     ---------- ]
c                  [                             2          2      ]
c                  [                                               ]
c                  [                            p2sq    msq - s23  ]
c                  [     0           0        - ----    ---------  ]
c                  [                             2          2      ]
c            y10 = [                                               ]
c                  [     s12        p2sq                msq - p3sq ]
c                  [   - ---      - ----        0       ---------- ]
c                  [      2          2                      2      ]
c                  [                                               ]
c                  [ msq - p4sq  msq - s23  msq - p3sq             ]
c                  [ ----------  ---------  ----------     msq     ]
c                  [     2           2          2                  ]

      include 'qlconstants.f'
      integer iep
      double precision msq,musq,
     . si,tabar,mean,fac,m3sqbar,m4sqbar,mp2sq,Y(4,4)
      double complex qlLi2omrat,qlLi2omx2,dilog(5),Ires(-2:0),qllnrat,
     . wlogtmu,wlogsmu,wlog2mu,wlog4mu

      msq=Y(4,4)
      si=2d0*Y(1,3)
      tabar=2d0*Y(2,4)
      m4sqbar=2d0*Y(1,4)
      m3sqbar=2d0*Y(3,4)
      mp2sq=2d0*Y(2,3)
      mean=sqrt(musq*msq)

      fac=si*tabar-mp2sq*m4sqbar
      wlogsmu=qllnrat(si,musq)
      wlogtmu=qllnrat(tabar,musq)
      wlog2mu=qllnrat(mp2sq,musq)
      wlog4mu=qllnrat(m4sqbar,musq)

      dilog(1)=qlLi2omrat(mp2sq,si)
      dilog(2)=qlLi2omrat(tabar,m4sqbar)
      dilog(3)=qlLi2omx2(mp2sq,m4sqbar,si,tabar)
      dilog(4)=qlLi2omx2(m3sqbar,tabar,mp2sq,msq)
      dilog(5)=qlLi2omx2(m3sqbar,m4sqbar,si,msq)

      Ires(-2)=czip
      Ires(-1)=wlog2mu+wlog4mu-wlogsmu-wlogtmu
      Ires( 0)=dilog(4)-dilog(5)
     . -2d0*dilog(1)+2d0*dilog(2)+2d0*dilog(3)
     . +2d0*Ires(-1)*qllnrat(mean,tabar)
      do iep=-2,0
      Ires(iep)=Ires(iep)/dcmplx(fac)
      enddo
      return
      end


      SUBROUTINE slUEEL (U, JFORMR,
     :                      JFORM, EPOCH, ORBINC, ANODE, PERIH,
     :                      AORQ, E, AORL, DM, JSTAT)
*+
*     - - - - - -
*      U E E L
*     - - - - - -
*
*  Transform universal elements into conventional heliocentric
*  osculating elements.
*
*  Given:
*     U         d(13)  universal orbital elements (Note 1)
*
*                 (1)  combined mass (M+m)
*                 (2)  total energy of the orbit (alpha)
*                 (3)  reference (osculating) epoch (t0)
*               (4-6)  position at reference epoch (r0)
*               (7-9)  velocity at reference epoch (v0)
*                (10)  heliocentric distance at reference epoch
*                (11)  r0.v0
*                (12)  date (t)
*                (13)  universal eccentric anomaly (psi) of date, approx
*
*     JFORMR    i      requested element set (1-3; Note 3)
*
*  Returned:
*     JFORM     d      element set actually returned (1-3; Note 4)
*     EPOCH     d      epoch of elements (TT MJD)
*     ORBINC    d      inclination (radians)
*     ANODE     d      longitude of the ascending node (radians)
*     PERIH     d      longitude or argument of perihelion (radians)
*     AORQ      d      mean distance or perihelion distance (AU)
*     E         d      eccentricity
*     AORL      d      mean anomaly or longitude (radians, JFORM=1,2 only)
*     DM        d      daily motion (radians, JFORM=1 only)
*     JSTAT     i      status:  0 = OK
*                              -1 = illegal combined mass
*                              -2 = illegal JFORMR
*                              -3 = position/velocity out of range
*
*  Notes
*
*  1  The "universal" elements are those which define the orbit for the
*     purposes of the method of universal variables (see reference 2).
*     They consist of the combined mass of the two bodies, an epoch,
*     and the position and velocity vectors (arbitrary reference frame)
*     at that epoch.  The parameter set used here includes also various
*     quantities that can, in fact, be derived from the other
*     information.  This approach is taken to avoiding unnecessary
*     computation and loss of accuracy.  The supplementary quantities
*     are (i) alpha, which is proportional to the total energy of the
*     orbit, (ii) the heliocentric distance at epoch, (iii) the
*     outwards component of the velocity at the given epoch, (iv) an
*     estimate of psi, the "universal eccentric anomaly" at a given
*     date and (v) that date.
*
*  2  The universal elements are with respect to the mean equator and
*     equinox of epoch J2000.  The orbital elements produced are with
*     respect to the J2000 ecliptic and mean equinox.
*
*  3  Three different element-format options are supported:
*
*     Option JFORM=1, suitable for the major planets:
*
*     EPOCH  = epoch of elements (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = longitude of perihelion, curly pi (radians)
*     AORQ   = mean distance, a (AU)
*     E      = eccentricity, e
*     AORL   = mean longitude L (radians)
*     DM     = daily motion (radians)
*
*     Option JFORM=2, suitable for minor planets:
*
*     EPOCH  = epoch of elements (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = argument of perihelion, little omega (radians)
*     AORQ   = mean distance, a (AU)
*     E      = eccentricity, e
*     AORL   = mean anomaly M (radians)
*
*     Option JFORM=3, suitable for comets:
*
*     EPOCH  = epoch of perihelion (TT MJD)
*     ORBINC = inclination i (radians)
*     ANODE  = longitude of the ascending node, big omega (radians)
*     PERIH  = argument of perihelion, little omega (radians)
*     AORQ   = perihelion distance, q (AU)
*     E      = eccentricity, e
*
*  4  It may not be possible to generate elements in the form
*     requested through JFORMR.  The caller is notified of the form
*     of elements actually returned by means of the JFORM argument:
*
*      JFORMR   JFORM     meaning
*
*        1        1       OK - elements are in the requested format
*        1        2       never happens
*        1        3       orbit not elliptical
*
*        2        1       never happens
*        2        2       OK - elements are in the requested format
*        2        3       orbit not elliptical
*
*        3        1       never happens
*        3        2       never happens
*        3        3       OK - elements are in the requested format
*
*  5  The arguments returned for each value of JFORM (cf Note 6: JFORM
*     may not be the same as JFORMR) are as follows:
*
*         JFORM         1              2              3
*         EPOCH         t0             t0             T
*         ORBINC        i              i              i
*         ANODE         Omega          Omega          Omega
*         PERIH         curly pi       omega          omega
*         AORQ          a              a              q
*         E             e              e              e
*         AORL          L              M              -
*         DM            n              -              -
*
*     where:
*
*         t0           is the epoch of the elements (MJD, TT)
*         T              "    epoch of perihelion (MJD, TT)
*         i              "    inclination (radians)
*         Omega          "    longitude of the ascending node (radians)
*         curly pi       "    longitude of perihelion (radians)
*         omega          "    argument of perihelion (radians)
*         a              "    mean distance (AU)
*         q              "    perihelion distance (AU)
*         e              "    eccentricity
*         L              "    longitude (radians, 0-2pi)
*         M              "    mean anomaly (radians, 0-2pi)
*         n              "    daily motion (radians)
*         -             means no value is set
*
*  6  At very small inclinations, the longitude of the ascending node
*     ANODE becomes indeterminate and under some circumstances may be
*     set arbitrarily to zero.  Similarly, if the orbit is close to
*     circular, the true anomaly becomes indeterminate and under some
*     circumstances may be set arbitrarily to zero.  In such cases,
*     the other elements are automatically adjusted to compensate,
*     and so the elements remain a valid description of the orbit.
*
*  References:
*
*     1  Sterne, Theodore E., "An Introduction to Celestial Mechanics",
*        Interscience Publishers Inc., 1960.  Section 6.7, p199.
*
*     2  Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983.
*
*  Called:  slPVEL
*
*  P.T.Wallace   Starlink   18 March 1999
*
*  Copyright (C) 1999 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION U(13)
      INTEGER JFORMR,JFORM
      DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM
      INTEGER JSTAT

*  Gaussian gravitational constant (exact)
      DOUBLE PRECISION GCON
      PARAMETER (GCON=0.01720209895D0)

*  Canonical days to seconds
      DOUBLE PRECISION CD2S
      PARAMETER (CD2S=GCON/86400D0)

      INTEGER I
      DOUBLE PRECISION PMASS,DATE,PV(6)

*  Unpack the universal elements.
      PMASS = U(1)-1D0
      DATE = U(3)
      DO I=1,3
         PV(I) = U(I+3)
         PV(I+3) = U(I+6)*CD2S
      END DO

*  Convert the position and velocity etc into conventional elements.
      CALL slPVEL(PV,DATE,PMASS,JFORMR,JFORM,EPOCH,ORBINC,ANODE,
     :               PERIH,AORQ,E,AORL,DM,JSTAT)

      END


module solab

contains

    subroutine zsolab(f,p,a,b,alpha,beta,n,k,retco)

    implicit none
    integer, intent(in) :: n,k
    integer, intent(out) :: retco
!    integer i,j,l,m
!   the above aren't used
    integer lda,ldb,sdim,ldvsl,ldvsr,lwork,info,ipiv(k)
    logical bwork(n)
    real(kind=8), intent(in)  :: a(n,n), b(n,n)
    real(kind=8), intent(out) :: f(n-k,k), p(k,k)
    real(kind=8) rwork(8*n)
!    complex*16 s(n,n), t(n,n)
    complex(kind=8) s(n,n), t(n,n)
!    complex*16 alpha(n),beta(n),vsl(n,n),vsr(n,n)
    complex(kind=8) vsl(n,n),vsr(n,n)
    complex(kind=8), intent(out) :: alpha(n)
    complex(kind=8), intent(out) :: beta(n)
!    complex*16 tempwork(1)
    complex(kind=8) tempwork(1)
!    complex*16, allocatable :: work(:)
    complex(kind=8), allocatable :: work(:)
!    complex*16 z11work(8*k)
    complex(kind=8) z11work(8*k)
!    complex*16 z11(k,k), z11i(k,k)
    complex(kind=8) z11(k,k), z11i(k,k)
!    complex*16 s11i(k,k), t11(k,k), pp(k,k)
    complex(kind=8) s11i(k,k), t11(k,k), pp(k,k)
!    complex*16 z21(n-k,k), eyek(k,k)
!    complex(kind=8) z21(n-k,k), eyek(k,k)
    complex(kind=8) z21(n-k,k)

    retco = 0
    lwork = -1
    s = dcmplx(a)
    t = dcmplx(b)

    ldvsl = n
    ldvsr = n
    lda = n
    ldb = n

    call zgges('N','V','S',funcg,n,s,lda,t,ldb,sdim,alpha,beta,vsl,ldvsl,vsr,ldvsr,tempwork,lwork,rwork,bwork,info)
    lwork = int(tempwork(1))
    allocate(work(lwork))

    call zgges('N','V','S',funcg,n,s,lda,t,ldb,sdim,alpha,beta,vsl,ldvsl,vsr,ldvsr,work,lwork,rwork,bwork,info)

    if ((abs(alpha(k))<abs(beta(k))) .or. (abs(alpha(k+1))>abs(beta(k+1)))) then
     print*, 'Error: wrong number of stable eigenvalues'
     retco = 1
     return
    end if

    z11  = vsr(1:k,1:k)
    z11i = vsr(1:k,1:k)
    z21  = vsr(k+1:n,1:k)
    s11i = s(1:k,1:k)
    t11  = t(1:k,1:k)
    call zgetrf(k,k,z11i,k,ipiv,info)
    call zgetri(k,z11i,k,ipiv,z11work,8*k,info)
    call ztrtri('U','N',k,s11i,k,info)

    f  = real(matmul(z21,z11i),kind=8)
    pp = matmul(s11i,t11)
    pp = matmul(z11,pp)
    pp = matmul(pp,z11i)
    p  = real(pp,kind=8)

    end subroutine

    logical function funcg(sii,tii)
!     complex*16 sii,tii
     complex(kind=8) sii,tii
     funcg = abs(sii)>abs(tii)
    end function

end module solab


      subroutine imppro
c
c     + + + PURPOSE + + +
c
c     Channel water surface profile analysis subroutine.
c     SR IMPPRO uses the standard step method to obtain
c     the water surface profile and energy slopes at each
c     node in the channel.
c
c     Called from: IMPINT
c     Author(s): A. Fogel
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
      include 'cimrou.inc'
c     read: b,ss,n,pypos,z,mdwit,dwt,rfrac,yc,frt,ncross
c     write: depth
c
c     + + + LOCAL VARIABLES + + +
c
      real area, hrad, cntrdp, v, vhead, theadc, y1, y2, hr23, r23, s1,
     1    chr, dz, yy1, yy2, dy, ddx, stage, thead1, s2, sfavg, floss,
     1    thdif, hhead, thead2, g, b, frt, ss, z(30), n, ydif
      integer iup, icsec, numnp1, nod, i, iter
c
c     + + + LOCAL DEFINITIONS + + +
c
c     area     - the flow area of the channel
c     b        - channel bottom width
c     chr      - channel roughness coefficient
c     cntrdp   - depth at the control section
c     ddx      - distance downstream
c     dy       - incremental change in depth
c     dz       - incremental change in downstream distance
c     floss    - friction loss
c     frt      - flow rate
c     g        - gravitational constant
c     hhead    - head variable
c     hr23     - hydraulic radius ** 2/3
c     hrad     - hydraulic radius
c     icsec    - number of cross sections
c     iter     - number of iterations
c     iup      - upstream routing flag
c     n        - manning's n
c     nod      - normal depth counter
c     numnp1   - number of points in cross section
c     r23      - 2/3 in manning's n equation
c     s1       - friction slope
c     s2       - friction slope
c     sfavg    - friction slope
c     ss       - side slopes
c     stage    - stage of the flow depth
c     thdif    - convergence head difference
c     thead1   - total head
c     thead2   - total head
c     theadc   - total head
c     v        - average flow velocity
c     vhead    - velocity head
c     y1       - flow depth
c     y2       - flow depth
c     ydif     - flow depth difference
c     yy1      - control section position
c     yy2      - control section position + 1
c     z(i)     - horizontal location
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c     calculate the hydraulic radius for the control section
c
      b = bwes
      ss = sses
      n = nes
c
      do 10 i = 1, ncross
        z(i) = zes(i)
   10 continue
c
      frt = qesr
      iup = 0
      cntrdp = yc
      g = 32.2
c
      if (iup.eq.0) then
        icsec = ncross
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      else
        icsec = 1
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      end if
c
c     calculate the velocity head and the total head for the control
c     section
c
      v = frt / area
      vhead = v * v / (2.0*g)
      theadc = pypos(icsec) + depth(icsec) + vhead
      y1 = depth(icsec)
      y2 = y1
c
c     calculate the friction slope using manning's equation
c
      r23 = 2.0 / 3.0
      chr = n / 1.486
      hr23 = hrad ** r23
      s1 = (v*chr/hr23) ** 2.0
c
c     begin loop over the cross sections and set up point to change depth
c     toward normal depth
c
      numnp1 = ncross - 1
c
      do 30 nod = 1, numnp1
c
        if (iup.eq.0) then
          icsec = ncross - nod
        else
          icsec = nod + 1
        end if
c
c       calculate the distance downstream (or upstream)
c
        if (iup.eq.0) then
          dz = z(icsec+1) - z(icsec)
          yy1 = pypos(icsec)
          yy2 = pypos(icsec+1)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        else
          dz = z(icsec) - z(icsec-1)
          yy1 = pypos(icsec-1)
          yy2 = pypos(icsec)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        end if
c
c       set first guess at the stage to that of the previous cross section
c       and set the depth equal to that of the previous cross section
c
        iter = 0
c
   20   iter = iter + 1
c
        if (iter.gt.mdwit) then
          write (6,1000) iter, mdwit, icsec
          stop
        end if
c
        stage = pypos(icsec) + y2
        y1 = y2
c
c       calculate the cross sectional area, hydraulic radius, and velocity
c       and total head at the cross section
c
        area = b * y1 + ss * y1 ** 2.
        hrad = area / (b+2.*y1*(ss**2.+1)**0.5)
c
        v = frt / area
        vhead = v * v / (2.0*g)
        thead1 = stage + vhead
c
c       calculate the friction slope using manning's equation
c
        hr23 = hrad ** r23
        s2 = (v*chr/hr23) ** 2.0
c
c       calculate the average friction slope over the reach and
c       the friction loss
c
        sfavg = 0.5 * (s1+s2)
        floss = sfavg * ddx
c
c       calculate the new total head
c
        if (iup.eq.0) then
          thead2 = theadc + floss
        else
          thead2 = theadc - floss
        end if
c
c       check for convergence
c
        thdif = thead2 - thead1
c
        if (abs(thdif).lt.dwt) then
          theadc = thead2
          s1 = s2
          depth(icsec) = thead2 - vhead - pypos(icsec)
          y2 = yc
          go to 30
c
        else
c
          hhead = 0.5 * (thead1+thead2)
c
c         y2 = y1*(thead2/thead1)
c
          y2 = hhead - pypos(icsec) - vhead
          ydif = y2 - y1
c
          if (abs(ydif).gt.rfrac*y1) then
            if (ydif.ge.0.0) then
              y2 = y1 + rfrac * y1
            else
              y2 = y1 - rfrac * y1
            end if
          end if
c
          go to 20
        end if
c
   30 continue
c
      return
c
 1000 format (//12x,'!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!',//
     1    7x,'WATER SURFACE PROFILE ITERATIONS (',i3,
     1    ') EXCEEDED MAXIMUM (',i3,')',/28x,'PROGRAM HALTED'/19x,
     1    'AT CROSS SECTION ',i2//12x,
     1    '!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!')
      end


!------------------------------------------------------------------------------!
!> Calculation of toroidal functions \f$P_{n-1/2}^m \left(z\right)\f$ and
!! \f$Q_{n-1/2}^m \left(z\right)\f$.
!------------------------------------------------------------------------------!
!> \note Copied and adapted from the DTORH1 routine by Segura and Gil
!! \cite Segura2000 .
!------------------------------------------------------------------------------!
module dtorh
#include <PB3D_macros.h>
    use num_vars, only: dp, pi, max_str_ln
    use messages
    use str_utilities

    implicit none
    private
    public dtorh1

   character(len=max_str_ln) :: err_msg                                         !< error message

contains
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !  INPUT :                                                         !
    !    Z        ARGUMENT OF THE FUNCTIONS                            !
    !    M        ORDER OF THE FUNCTIONS                               !
    !    NMAX     MAXIMUM DEGREE OF THE FUNCTIONS :                    !
    !             WE GET  FUNCTIONS OF ALL THE ORDERS BELOW            !
    !             MIN(NEWN,NMAX). NEWN IS DEFINED BELOW .              !
    !  OUTPUT :                                                        !
    !   *IF MODE IS EQUAL TO 0:                                        !
    !    PL(N)                                                         !
    !             THESE VALUES ARE KEPT IN AN ARRAY                    !
    !    QL(N)                                                         !
    !             THESE VALUES ARE KEPT IN AN ARRAY                    !
    !                                                                  !
    !    NEWN     MAXIMUM ORDER OF FUNCTIONS CALCULATED WHEN           !
    !             PL (NMAX+1) IS LARGER THAN 1/TINY                    !
    !             (OVERFLOW LIMIT = 1/TINY, TINY IS DEFINED BELOW)     !
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !> Calculates toroidal harmonics of a fixed order \c m and degrees
    !! up to \c nmax.
    !!
    !! Optionally, the \c mode can be specified to be different from 0 [default]
    !!  - if \c mode=1:
    !!      - The set of functions evaluated is:
    !!        \f[\frac{P_{n-1/2}^m \left(z\right)}{\Gamma(m+1/2)} \ ,\quad
    !!          \frac{Q_{n-1/2}^m \left(z\right)}{\Gamma(m+1/2)},\f]
    !!        which are respectively stored in the arrays \c pl(n), \c ql(n).
    !!      - newn refers to this new set of functions.
    !!      - Note 1. and note 2. also apply in this case.
    !!  - if \c mode=2:
    !!      - The code performs as for mode 1, but the restriction \f$ z<20 \f$.
    !!      - For the evaluation of the continued fraction is not considered.
    !!
    !! Also, the parameter \c ipre can be used to select a different precision:
    !!  - For \c ipre=1, the precision is \f$10^{-12}\f$, taking
    !!    \f$\epsilon<10^{-12}\f$
    !!  - For \c ipre=2, the precision is \f$10^{-8}\f$, taking
    !!    \f$\epsilon<10^{-8}\f$
    !!
    !! where \f$\epsilon\f$ controls the accuracy.
    !!
    !! \warning Use \c mode 2 only if high \c m 's for \f$z>20\f$ are required.
    !! The evaluation of the cf may fail to converge for too high \c z 's.
    !!
    !! \note
    !!    -# For a precision of \f$10^{-12}\f$, if \f$z>5\f$ and \f$z/m>0.22\f$,
    !!    the code uses a series expansion for \c pl(0).\n
    !!    When \f$z<20\f$ and \f$z/m<0.22\f$ a continued fraction is applied.
    !!    -# For a precision of \f$10^{-8}\f$, if \f$z>5\f$ and \f$z/m>0.12\f$,
    !!    the code uses a series expansion for \c pl(0).\n
    !!    When \f$z<20\f$ and \f$z/m<0.12\f$ a continued fraction is applied.
    !!
    !! \return ierr
    integer function dtorh1(z,m,nmax,pl,ql,newn,mode,ipre) result(ierr)
        character(*), parameter :: rout_name = 'DTORH1'

        ! input / output
        real(dp), intent(in) :: z                                               !< (real) point at which toroidal harmonics are evaluated
        integer, intent(in) :: m                                                !< order of toroidal harmonics (\c m>0)
        integer, intent(in) :: nmax                                             !< maximum degree of toroidal harmonics (\c nmax>0)
        real(dp), intent(inout) :: pl(0:nmax)                                   !< toroidal harmonics of first kind \f$P_{n-1/2}^m\left(z\right)\f$
        real(dp), intent(inout) :: ql(0:nmax)                                   !< toroidal harmonics of second kind \f$Q_{n-1/2}^m\left(z\right)\f$
        integer, intent(inout) :: newn                                          !< maximum order of functions calculated when <tt> pl(nmax+1)>1/tiny </tt> with <tt>tiny=</tt>\f$10^{-290}\f$
        integer, intent(in), optional :: mode                                   !< mode that controls output
        integer, intent(in), optional :: ipre                                   !< precision

        ! local variables
        INTEGER NMAXP,MP,NP,N,ICAL,I
        INTEGER :: mode_loc, ipre_loc
        REAL(dp) OVER,TINYSQ,QZ,PISQ,FL,CC,AR,GAMMA,FC,QDC1,QARGU,&
            &ARGU1,DFACQS,FCP,DD,D1,QM0,DFAC3,DFAC4,PL0
        real(dp), allocatable :: PL_loc(:), QL_loc(:)                           ! local copy of pl and ql, possibly larger
        !REAL(dp) DPPI                                                           ! Is never used?
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! THE DIMENSION OF QLMM (INTERNAL ARRAY) MUST BE GREATER THAN M    !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        REAL(dp)  QLMM(0:1001),PR(2)
        real(dp), PARAMETER :: EPS=1.E-14_dp, TINY=1.E-290_dp

        ! initialize ierr
        ierr = 0

        ! test
        if (NMAX.lt.0) then
            ierr = 1
            err_msg = 'Lowest possible degree is 0. Use recursive properties &
                &of toroidal functions if you need lower.'
            CHCKERR(err_msg)
        end if

        ! set optional parameters
        mode_loc = 0
        if (present(mode)) mode_loc = mode
        ipre_loc = 1
        if (present(ipre)) ipre_loc = ipre

        OVER=1._dp/TINY
        TINYSQ=DSQRT(TINY)
        IF ((ipre_loc.NE.1).AND.(ipre_loc.NE.2)) THEN
            ierr = 1
            err_msg = 'IPRE MUST BE 1 OR 2'
            CHCKERR(err_msg)
        END IF

        PR(1)=.22_dp
        PR(2)=.12_dp
        NMAXP=NMAX-1                                                            ! decremented by one to get more logical ouptut
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   EPS: REQUIRED ACCURACY FOR THE CONTINUED FRACTION     !
        !        (MODIFIED LENTZ)                                 !
        !   TINY: SMALL PARAMETER TO PREVENT OVERFLOWS IN THE CF  !
        !          (CLOSE TO THE UNDERFLOW LIMIT)                 !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        IF (Z.LE.1._dp) THEN
            ierr = 1
            err_msg = 'IMPROPER ARGUMENT. Z MUST BE GREATER THAN 1'
            CHCKERR(err_msg)
        END IF
        QZ=Z
        PISQ=DSQRT(PI)
        !DPPI=DSQRT(2._dp)/PISQ                                                  ! Is never used?
        FL=M/2._dp
        CC=ABS(FLOAT(INT(FL))-FL)
        IF (CC.LT.0.4_dp) THEN
            AR=1.
        ELSE
            AR=-1.
        END IF
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE CHOOSE EXPANSION OR CF FOR PL(0) DEPENDING ON THE VALUES !
        !   OF Z,M AND MODE                                             !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ICAL=1
        IF (M.NE.0) THEN
            IF ((Z/M).GT.PR(ipre_loc)) ICAL=2
            IF (Z.LT.5._dp) THEN
                ICAL=1
            ELSE IF (Z.GT.20.D0) THEN
                IF ((mode_loc.NE.2).AND.(ICAL.EQ.1)) ICAL=0
            END IF
            IF (ICAL.EQ.0) THEN
                ierr =1
                CHCKERR('YOU MUST CHOOSE MODE=2')
            END IF
        ELSE
            IF (Z.LT.5.D0) THEN
              ICAL=1
            ELSE
              ICAL=2
            END IF
        END IF
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE USE THE CODE IF NMAX IS GREATER THAN OR EQUAL TO 2  !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        IF(NMAXP.LT.2) NMAXP=2

        ! set up local PL, QL
        allocate(PL_loc(0:nmaxp+1))
        allocate(QL_loc(0:nmaxp+1))

        IF (mode_loc.EQ.0) THEN
            GAMMA=GAMMAH(M,OVER)*AR*PISQ
            IF (ABS(GAMMA).LT.TINY) THEN
                ierr =1
                err_msg = 'M IS TOO LARGE FOR MODE=0, BETTER TRY MODE=1'
                CHCKERR(err_msg)
            END IF
        ELSE
            GAMMA=AR
        END IF
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE EVALUATE THE CONTINUED FRACTION  USING     !
        !   LENTZ-THOMPSON                                !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ierr = FRAC(Z,M,0,EPS,TINYSQ,FC)
        CHCKERR('')
        QDC1=QZ*QZ-1._dp
        QARGU=QZ/DSQRT(QDC1)
        !DFAC1=DPPI*GAMMA/PI                                                     ! Is never used?
        !DFAC2=GAMMA/DPPI                                                        ! Is never used?
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE EVALUATE Q_{-1/2},Q^{1}_{-1/2}               !
        !   USING SLATEC ROUTINES FOR ELLIPTIC FUNCTIONS    !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ARGU1=DSQRT(2._dp/(Z+1._dp))
        QLMM(0)=ARGU1*ELLIP1(ARGU1)
        QLMM(1)=-1._dp/DSQRT(2._dp*(QZ-1._dp))*ELLIP2(ARGU1)
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE APPLY FORWARD RECURRENCE IN M FOR Q'S  !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        MP=1
        IF (mode_loc.EQ.0) THEN
          1 IF ((MP.LE.M).AND.(ABS(QLMM(MP)).LT.OVER)) THEN
                QLMM(MP+1)=-2._dp*MP*QARGU*QLMM(MP)-&
                    &(MP-0.5_dp)*(MP-0.5_dp)*QLMM(MP-1)
                MP=MP+1
                GOTO 1
            ENDIF
            IF ((MP-1).NE.M) THEN
                ierr = 1
                err_msg = 'M IS TOO LARGE FOR MODE=0, BETTER TRY MODE=1'
                CHCKERR(err_msg)
            END IF
        ELSE
            QLMM(0)=QLMM(0)/PISQ
            QLMM(1)=QLMM(1)*2._dp/PISQ
          2 IF ((MP.LE.M).AND.(ABS(QLMM(MP)).LT.OVER)) THEN
                D1=MP+0.5_dp
                QLMM(MP+1)=-2._dp*MP*QARGU*QLMM(MP)/D1&
                    &-(MP-0.5_dp)*QLMM(MP-1)/D1
                MP=MP+1
                GOTO 2
            ENDIF
            IF ((MP-1).NE.M) THEN
                ierr = 1
                err_msg = 'M IS TOO LARGE FOR MODE=1,2'
                CHCKERR(err_msg)
            END IF
        END IF
        !NMMAX=M                                                                 ! Is never used?
        DFACQS=-(GAMMA/QLMM(M+1))*GAMMA/PI
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   EVALUATION OF PL(0)                             !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        IF (ICAL.EQ.1) THEN
            !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            !   WE CALCULATE THE CF FOR P'S                     !
            !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            ierr = FRACPS(QARGU,M+1,0,EPS,TINYSQ,FCP)
            CHCKERR('')
            DD=M+0.5_dp
            IF (mode_loc.NE.0) THEN
                FCP=FCP/DD
                DFACQS=DFACQS/DD
            END IF
            PL_loc(0)=DFACQS/DSQRT(QDC1)/(1._dp-FCP*QLMM(M)/QLMM(M+1))
        ELSE
            CALL EXPAN(Z,mode_loc,ipre_loc,OVER,QARGU,M,PL0)
            PL_loc(0)=PL0
        END IF
        QM0=QLMM(M)
        DFAC3=(GAMMA/QM0)*GAMMA/PI/(0.5_dp-M)
        PL_loc(1)=PL_loc(0)*FC+DFAC3
        NP=1
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE USE THE RECURRENCE RELATIONS FOR P'S   !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      3 IF ((NP.LE.NMAXP).AND.(ABS((NP-M+0.5_dp)*PL_loc(NP)).LT.OVER)) THEN
            PL_loc(NP+1)=(2._dp*NP*Z*PL_loc(NP)-(NP+M-0.5_dp)*PL_loc(NP-1))/&
                &(NP-M+0.5_dp)
            NP=NP+1
            GOTO 3
        ENDIF
        NMAXP=NP-1
        NEWN=NMAXP+1                                                            ! incremented by 1 to get more logical output
        DFAC4=(FACTCO(NMAXP,PL_loc(NMAXP+1),M)*GAMMA)*GAMMA/PI/(NMAXP+M+0.5_dp)
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE EVALUATE THE CONTINUED FRACTION USING LENTZ-THOMPSON  !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ierr = FRAC(Z,M,NMAXP,EPS,TINYSQ,FC)
        CHCKERR('')
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   EVALUATION OF PL(NMAX+1) AND PL(NMAX) USING   !
        !   THE WRONSKIAN W{PL(NMAX),QL(NMAX)},           !
        !   THE KNOWN VALUES OF PL(NMAX+1) AND PL(NMAX)   !
        !   THE VALUE OF H = QL(NMAX+1)/QL(NMAX)          !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        QL_loc(NMAXP)=DFAC4/(1._dp-FC*PL_loc(NMAXP)/PL_loc(NMAXP+1))
        QL_loc(NMAXP+1)=QL_loc(NMAXP)*FC
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        !   WE USE THE BACKWARD RECURRENCE RELATION   !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        DO 4 I=1,NMAXP
            NP=NMAXP+1-I
            N=NP-1
            QL_loc(N)=((NP+NP)*Z*QL_loc(NP)-(NP-M+0.5_dp)*QL_loc(NP+1))/&
                &(NP+M-0.5_dp)
      4 CONTINUE

        ! copy local PL and QL back
        PL = PL_loc(0:NMAX)
        QL = QL_loc(0:NMAX)
    end function DTORH1

    ! Adapted to 100k iterations in stead of 10k.
    integer function FRAC(Z,M,NMAX,EPS,TINYSQ,FC) result(ierr)
        character(*), parameter :: rout_name = 'FRAC'

        INTEGER M,NMAX,N,MM
        REAL(dp) Z,EPS,TINYSQ,FC,DZ2,DN0,DN1,DN2,DN3,DN4,B,A,C0,D0,DELTA

        ! initialize ierr
        ierr = 0

        N=NMAX
        MM=0
        DZ2=Z+Z
        DN0=N+M
        DN1=N+1._dp
        DN2=DN0+0.5_dp
        DN3=DN0-0.5_dp
        DN4=1._dp-M-M
        B=2._dp*DN1*Z/DN2
        A=1._dp
        FC=TINYSQ
        C0=FC
        D0=0._dp
     81 D0=B+A*D0
        IF (DABS(D0).LT.TINYSQ) D0=TINYSQ
        C0=B+A/C0
        IF (DABS(C0).LT.TINYSQ) C0=TINYSQ
        D0=1._dp/D0
        DELTA=C0*D0
        FC=FC*DELTA
        MM=MM+1
        A=-(1.D0+DN4/(DN3+MM))
        B=DZ2*(DN1+MM)/(DN2+MM)
        IF (MM.LT.1000000) THEN
            IF (DABS(DELTA-1.D0).GT.EPS) GOTO 81
        END IF
        IF (MM.EQ.1000000) then
            ierr =1
            err_msg = 'CF CONVERGENCE FAILS FOR Z = '//trim(r2str(Z))
            CHCKERR(err_msg)
        END IF
    end function FRAC

    integer function FRACPS(QZ,M,N,EPS,TINYSQ,FC) result(ierr)
        character(*), parameter :: rout_name = 'FRACPS'

        INTEGER M,N,MM
        REAL(dp) QZ,EPS,TINYSQ,FC,DN2,DZ2,DM,B,A,C0,D0,DELTA

        ! initialize ierr
        ierr = 0

        MM=0
        DN2=N*N
        DZ2=QZ+QZ
        DM=M-0.5_dp
        B=DZ2*M
        A=DN2-DM*DM
        FC=TINYSQ
        C0=FC
        D0=0._dp
     82 D0=B+A*D0
        IF (DABS(D0).LT.TINYSQ) D0=TINYSQ
        C0=B+A/C0
        IF (DABS(C0).LT.TINYSQ) C0=TINYSQ
        D0=1._dp/D0
        DELTA=C0*D0
        FC=FC*DELTA
        MM=MM+1
        A=DN2-(MM+DM)*(MM+DM)
        B=DZ2*(MM+M)
        IF (MM.LT.1000000) THEN
            IF (ABS(DELTA-1._dp).GT.EPS) GOTO 82
        END IF
        IF (MM.EQ.1000000) then
            ierr =1
            err_msg = 'CF CONVERGENCE FAILS FOR QZ = '//trim(r2str(QZ))
            CHCKERR(err_msg)
        END IF
    end function FRACPS

    REAL(dp) FUNCTION ELLIP2(AK)
        REAL(dp) AK
        REAL(dp) Q

        Q=(1._dp-AK)*(1._dp+AK)
        ELLIP2=DRF(Q)-(AK)**2*DRD(Q)/3.D0
    END FUNCTION ELLIP2

    REAL(dp) FUNCTION ELLIP1(AK)
        REAL(dp) AK

        ELLIP1=DRF((1._dp-AK)*(1._dp+AK))
    END FUNCTION ELLIP1

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !  WE USE SLATEC ROUTINES IN THE EVALUATION OF ELLIPTIC INTEGRALS   !
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    REAL(dp) FUNCTION DRF (Y)
        REAL(dp) EPSLON, ERRTOL
        REAL(dp) C1, C2, C3, E2, E3, LAMDA
        REAL(dp) MU, S, XN, XNDEV
        REAL(dp) XNROOT, Y, YN, YNDEV, YNROOT, ZN, ZNDEV, ZNROOT
        LOGICAL FIRST
        SAVE ERRTOL,C1,C2,C3,FIRST
        DATA FIRST /.TRUE./

        !***FIRST EXECUTABLE STATEMENT  DRF
        IF (FIRST) THEN
            ERRTOL = 1.E-8_dp
            C1 = 1.0_dp/24.0_dp
            C2 = 3.0_dp/44.0_dp
            C3 = 1.0_dp/14.0_dp
        ENDIF
        FIRST = .FALSE.
        DRF = 0.0_dp
        XN = 0._dp
        YN = Y
        ZN = 1._dp

     30 MU = (XN+YN+ZN)/3.0_dp
        XNDEV = 2.0_dp - (MU+XN)/MU
        YNDEV = 2.0_dp - (MU+YN)/MU
        ZNDEV = 2.0_dp - (MU+ZN)/MU
        EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV))
        IF (EPSLON.LT.ERRTOL) GO TO 40
        XNROOT = SQRT(XN)
        YNROOT = SQRT(YN)
        ZNROOT = SQRT(ZN)
        LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
        XN = (XN+LAMDA)*0.250_dp
        YN = (YN+LAMDA)*0.250_dp
        ZN = (ZN+LAMDA)*0.250_dp
        GO TO 30

     40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
        E3 = XNDEV*YNDEV*ZNDEV
        S  = 1.0_dp + (C1*E2-0.10_dp-C2*E3)*E2 + C3*E3
        DRF = S/SQRT(MU)
    END FUNCTION DRF

    REAL(dp) FUNCTION DRD (Y)
        REAL(dp) EPSLON, ERRTOL
        REAL(dp) C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
        REAL(dp) MU, POWER4, SIGMA, S1, S2, XN, XNDEV
        REAL(dp) XNROOT, Y, YN, YNDEV, YNROOT,  ZN, ZNDEV, ZNROOT
        LOGICAL FIRST
        SAVE ERRTOL, C1, C2, C3, C4, FIRST
        DATA FIRST /.TRUE./

        !***FIRST EXECUTABLE STATEMENT  DRD
        IF (FIRST) THEN
            ERRTOL = 1.E-8_dp
            C1 = 3.0_dp/14.0_dp
            C2 = 1.0_dp/6.0_dp
            C3 = 9.0_dp/22.0_dp
            C4 = 3.0_dp/26.0_dp
        ENDIF
        FIRST = .FALSE.

        ! CALL ERROR HANDLER IF NECESSARY.

        DRD = 0.0_dp

        XN = 0._dp
        YN = Y
        ZN = 1._dp
        SIGMA = 0.0_dp
        POWER4 = 1.0_dp

     30 MU = (XN+YN+3.0_dp*ZN)*0.20_dp
        XNDEV = (MU-XN)/MU
        YNDEV = (MU-YN)/MU
        ZNDEV = (MU-ZN)/MU
        EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
        IF (EPSLON.LT.ERRTOL) GO TO 40
        XNROOT = SQRT(XN)
        YNROOT = SQRT(YN)
        ZNROOT = SQRT(ZN)
        LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
        SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA))
        POWER4 = POWER4*0.250_dp
        XN = (XN+LAMDA)*0.250_dp
        YN = (YN+LAMDA)*0.250_dp
        ZN = (ZN+LAMDA)*0.250_dp
        GO TO 30

     40 EA = XNDEV*YNDEV
        EB = ZNDEV*ZNDEV
        EC = EA - EB
        ED = EA - 6.0_dp*EB
        EF = ED + EC + EC
        S1 = ED*(-C1+0.250_dp*C3*ED-1.50_dp*C4*ZNDEV*EF)
        S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
        DRD = 3.0_dp*SIGMA + POWER4*(1.0_dp+S1+S2)/(MU*SQRT(MU))
    END FUNCTION DRD

    REAL(dp) FUNCTION GAMMAH(N,OVER)
        INTEGER N,I,J
        REAL(dp) OVER

        I=N
        J=2*I-1
        GAMMAH=1._dp
     85 IF ((J.GE.1).AND.(GAMMAH.LT.OVER)) THEN
            GAMMAH=GAMMAH*J/2._dp
            I=I-1
            J=2*I-1
            GOTO 85
        ENDIF
        IF (J.GT.1) THEN
            GAMMAH=0._dp
        END IF
    END FUNCTION GAMMAH

    REAL(dp) FUNCTION FACTCO(N,PL,M)
        INTEGER N,M,J
        REAL(dp) PL,X1,X2

        FACTCO=1._dp/PL
        X1=M+0.5_dp
        X2=-M+0.5_dp
        J=N
    86  IF (J.GE.0) THEN
            FACTCO=FACTCO*(J+X1)/(J+X2)
            J=J-1
            GOTO 86
        ENDIF
    END FUNCTION FACTCO

    SUBROUTINE EXPAN(Z,MODE,IPRE,OVER,QARGU,M,PL)
        INTEGER MODE,IPRE,M,K,I
        REAL(dp) Z,OVER,QARGU,PL,PISQ,DB,FL,CC,DZ,GAMMA,AR,&
            &DFAC,DF1,A0,Z2I,DA1,DA2,DELTA,SUM,DCC,DCCP,DKK
        REAL(dp) PRECI(2)

        PRECI(1)=1.E-13_dp
        PRECI(2)=1.E-9_dp
        PISQ=DSQRT(PI)
        DB=2._dp*DLOG(2._dp)
        FL=M/2.
        CC=ABS(FLOAT(INT(FL))-FL)
        IF (CC.LT.0.4_dp) THEN
            AR=1.
        ELSE
            AR=-1.
        END IF
        DZ=1._dp
        DO 100 I=1,M
            DZ=DZ/QARGU
    100 CONTINUE
        IF (MODE.EQ.0) THEN
            GAMMA=GAMMAH(M,OVER)*AR*PISQ
        ELSE
            GAMMA=AR
        END IF
        DFAC=2._dp/PI*DZ*GAMMA/PISQ
        DF1=DLOG(2._dp*Z)
        A0=1._dp/DSQRT(2._dp*Z)
        Z2I=1._dp/(Z*Z)
        DELTA=1._dp
        SUM=0._dp
        K=0
        DA2=FACTOR(M,0)
        DA1=DB+PSI(M,0)
     87 DELTA=(DF1+DA1)*DA2*A0
        SUM=SUM+DELTA
        DCC=0.5_dp+M+2._dp*K
        DCCP=DCC+1._dp
        DKK=K+1._dp
        DA2=DA2*DCCP*DCC/(DKK*DKK)
        DA1=DA1+1._dp/DKK-1._dp/DCCP-1._dp/DCC
        K=K+1
        A0=A0*0.25_dp*Z2I
        IF (ABS(DELTA/SUM).GT.PRECI(IPRE)) GOTO 87
        PL=SUM*DFAC
    END SUBROUTINE EXPAN

    REAL(dp) FUNCTION FACTOR(M,K)
        INTEGER M,K,N,I,J
        REAL(dp) X1

        FACTOR=1._dp
        IF (K.GE.1) THEN
        X1=M+0.5_dp
        N=2*K-1
        I=K
        J=N
     88 IF (J.GE.0) THEN
            FACTOR=FACTOR*(J+X1)/I/I
            J=J-1
            I=I-1
            IF (I.EQ.0) I=1
                GOTO 88
            ENDIF
        END IF
    END FUNCTION FACTOR

    REAL(dp) FUNCTION PSI(M,K)
        INTEGER M,K,N,J,I
        REAL(dp) FACTR1,FACTR2
        PSI=0._dp
        FACTR1=0._dp
        FACTR2=0._dp
        N=2*K+M
        J=1
        IF (K.GE.1) THEN
         89 IF (J.LE.K) THEN
                FACTR1=FACTR1+1._dp/J
                J=J+1
                GOTO 89
            ENDIF
        END IF
        I=1
     90 IF (I.LE.N) THEN
            FACTR2=FACTR2+1._dp/(2._dp*I-1._dp)
            I=I+1
            GOTO 90
        ENDIF
        IF (N.EQ.0) FACTR2=0._dp
        PSI=FACTR1-2._dp*FACTR2
    END FUNCTION PSI
end module


************************************************************************
*
*     Function PVALUE                                Called by: AMLPVAL
*
*     computes likelihood ratio test p-value (PVALUE) for AMLE
*     parameter estimates
*
*     XLIKE_S  Log-Likelihood associated with simple model (S)
*     XLIKE_C  Log-Likelihood associated with complex model (C)
*
************************************************************************
      DOUBLE PRECISION FUNCTION PVALUE(XLIKE_S,XLIKE_C,LDOUT)
*
*     function arguments
*
      DOUBLE PRECISION XLIKE_S,XLIKE_C
      INTEGER*4 LDOUT
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION A0,A1,AN,ANA,AP,B0,B1,DEL,FAC,G,GOLD,SUM,X
*
*     format statement
*
 1000 FORMAT(/,' WARNING: Maximum iterations exceeded when computing ',
     &       'P VALUE.',/,10X,'P VALUE not reported.')
*
*     0.57236... is gammln(0.5d0)
*
      IF(XLIKE_C .LE. XLIKE_S) THEN
         PVALUE = 1.D0
      ELSE
         X = XLIKE_C-XLIKE_S
         IF (X.LT.1.5D0) THEN
            AP = 0.5D0
            SUM = 2.D0
            DEL = 2.D0
            DO 10 I=1,10000
               AP = AP+1.D0
               DEL = DEL*X/AP
               SUM = SUM+DEL
               IF(ABS(DEL).LT.ABS(SUM)*3.D-12) THEN
                  PVALUE = 1.D0-SUM
     &                   * EXP(-X+0.5D0*LOG(X)-0.5723649429133818D0)
                  RETURN
               ENDIF
 10         CONTINUE
            WRITE (LDOUT,1000)
            PVALUE = 9999999.99
         ELSE
            GOLD = 0.D0
            A0 = 1.D0
            A1 = X
            B0 = 0.D0
            B1 = 1.D0
            FAC = 1.D0
            DO 20 I=1,10000
               AN = I
               ANA = AN-0.5D0
               A0 = (A1+A0*ANA)*FAC
               B0 = (B1+B0*ANA)*FAC
               A1 = X*A0+AN*FAC*A1
               B1 = X*B0+AN*FAC*B1
               IF(A1.NE.0.D0)THEN
                  FAC = 1.D0/A1
                  G = B1*FAC
                  IF(ABS((G-GOLD)/G).LT.3.D-12) THEN
                     PVALUE = EXP(-X+0.5D0*LOG(X)-0.5723649429133818D0)
     &                        * G
                     RETURN
                  ENDIF
                  GOLD = G
               ENDIF
 20         CONTINUE
            WRITE (LDOUT,1000)
            PVALUE = 9999999.99
         ENDIF
      ENDIF

      RETURN
      END


program test_sza
!! test day rollover
use phys_consts, only: wp
use timeutils, only: sza

implicit none (type, external)

real(wp), parameter :: pi = 4._wp*atan(1._wp)

print *, sza(2015,1,1, 0._wp, 0._wp, 0._wp)*180/pi
print *, sza(2015,6,21, 0._wp, 0._wp, 0._wp)*180/pi
print *, sza(2015,6,1, 43200._wp, 0._wp, 0._wp)*180/pi

print *, sza(2015,1,1, 0._wp, 45._wp, 45._wp)*180/pi
print *, sza(2015,6,21, 0._wp, 45._wp, 45._wp)*180/pi
print *, sza(2015,6,21, 43200._wp, 45._wp, 45._wp)*180/pi

end program


      programs_pscorg
      real*4pi,twopi
      real*4lcn2
      real*4l_s,l_p
      parameter(l_s=10.24)
      parameter(l_p=0.02)
      integer*4nsise
      parameter(nsize=256)
      realkk,kapmax,kapmin,l_0,dkap,lambda,l_o
      real*4pha_re(nsize,nsize),pha_im(nsize,nsize)
      character*30ifile,ofile
      integer*4f_in
      parameter(f_in=11)
      character*80comment,ocomments
      integer*4seed
      pi=3.141592653
      twopi=2.*pi
      lcn2=5.0e-13
      calljlp_begin
      calljlp_inquifmt
      write(*,10)
   10 format(1x,' input ascii file name : ',$)
      read(*,'(a)')ifile
      open(unit=f_in,file=ifile,status='old')
   30 format(a80)
   35 format(1x,a80)
      do40j=1,100
      read(f_in,30,end=100)comment
      write(*,35)comment
      if(comment(1:1).eq.'!')goto40
      if(comment(1:1).eq.'R'.or.comment(1:1).eq.'r')then
      read(f_in,*)seed
      endif
      if(comment(1:1).eq.'T'.or.comment(1:1).eq.'t')then
      read(f_in,*)l_0,l_o
      endif
      if(comment(1:1).eq.'W'.or.comment(1:1).eq.'w')then
      read(f_in,*)lambda
      endif
   40 continue
  100 continue
      write(6,36)seed,l_0,l_o,lambda
      write(ocomments,36)seed,l_0,l_o,lambda
   36 format(' seed=',I6,' L0 = ',G10.4,' lo = ',G10.4,' Lambda = ',G10.
     +4)
      kk=twopi/lambda
      work=min(l_s,l_0)
      kapmin=twopi/work
      work=max(l_o,l_p)
      kapmax=twopi/work
      dkap=twopi/l_s
      calljlp_random_init(seed)
      callscreen(pha_re,pha_im,nsize,kk,kapmax,kapmin,lcn2,dkap)
      ofile=' '
      print*,' output of phase screen (real part)'
      calljlp_writeimag(pha_re,nsize,nsize,nsize,ofile,ocomments)
      ofile=' '
      print*,' output of phase screen (imaginary part)'
      calljlp_writeimag(pha_im,nsize,nsize,nsize,ofile,ocomments)
      calljlp_end
      stop
      end
      subroutinescreen(pha_re,pha_im,nsize,kk,kapmax,kapmin,lcn2,dkap)
      real*4pha_re(nsize,nsize),pha_im(nsize,nsize)
      real*4fs,fso,pi,twopi
      real*4kk,kapmax,kapmin,lcn2,dkap,u,wrand,work
      real*4kap
      integer*4Nc
      pi=3.141592653
      twopi=2.*pi
      Nc=nsize/2+1
      fs0=0.033*pi*lcn2*kk*kk*2.0*dkap*dkap
      do100jy=1,nsize
      do110jx=1,nsize
      kap=dkap*sqrt(float((jx-Nc)*(jx-Nc)+(jy-Nc)*(jy-Nc)))
      kap=max(kap,dkap)
      atten=1.0
      if(kap.gt.kapmax)then
      atten=exp(-(kap-kapmax)/(5.0*dkap))
      elseif(kap.lt.kapmin)then
      atten=exp(-(kapmin-kap)/(5.0*dkap))
      endif
   10 calljlp_random(u)
      if(u.le.0.0)goto10
      radi=sqrt(-2.0*log(u))
      fs=fs0*kap**(-11.0/3.0)
      work=atten*sqrt(fs)*radi
      calljlp_random(wrand)
      wrand=wrand*twopi
      pha_re(jx,jy)=work*cos(wrand)
      pha_im(jx,jy)=work*sin(wrand)
  110 continue
  100 continue
      write(*,555)nsize,nsize
  555 format('+','start ',i3,'x',i3,' sized fft              ')
      kod=1
      callfft_2d(pha_re,pha_im,nsize,nsize,nsize,kod)
      write(*,666)
  666 format('+','end fft for screen                         ')
      DO80000jy=1,nsize
      DO80001jx=1,nsize
      work=pha_re(jx,jy)
      pha_re(jx,jy)=cos(work)
      pha_im(jx,jy)=sin(work)
80001 CONTINUE
80000 CONTINUE
      return
      end


module stencil_test_module

  use amrex_fort_module, only : dim=>amrex_spacedim
  implicit none

  private

  public :: get_bndry_grad_stencil, apply_bndry_grad_stencil, init_phi

contains

  subroutine get_bndry_grad_stencil(stencil,stencilB,baseiv,normals,centroids,ivs,num,dx) bind(C,name="get_bndry_grad_stencil")
    integer, intent(in) :: num
    double precision, intent(inout) :: stencil(0:2,0:2,num)
    double precision, intent(inout) ::      stencilB(num)
    integer,          intent(inout) ::    baseiv(dim,num)
    double precision, intent(in   ) ::   normals(dim,num)
    double precision, intent(in   ) :: centroids(dim,num)
    integer,          intent(in   ) ::       ivs(dim,num)
    double precision, intent(in   ) :: dx
    integer :: i, c(dim), s(dim), iv(dim), sh(dim)
    double precision :: n(dim), b(dim), x(2), y(2), d(2), fac

    ! Rotate work to 1st quadrant, where 1-component is "independent" such that ABS(n(1)/n(2)) > 1.
    ! Find 2 quadratically interpolated values at a=(x1a,x2a)=(1,x2a) and b=(x1b,x2b)=(2,x2b) along
    ! ray normal to boundary, and intersecting eb at centroid.  By construction, x2a<x1a and x2b<x1b
    ! so x2a will lay between (x1a,0) and (x1a,2), and x2b will lay between (x1b,0) and (x1b,2).
    ! These interpolated values at a and b, plus the Dirichlet value at the eb are then used
    ! to compute a normal gradient at the eb.  The resulting stencil contains 6+1 points, and
    ! is stored in a 3x3 matrix plus an aux value.  The normal gradient will then be evaluated:
    !
    !      dudn(i) = u(baseiv(i):baseiv(i)+(2,2)) . stencil(0:2,0:2,i)
    !                    + bcval(ivs(i)) . stencilB(i)
    !
    stencil(:,:,1:num) = 0.d0
    baseiv(:,1:num) = 0

    fac = 1.d0 / dx

    do i=1,num

       n(:) = normals(:,i)

       c(1) = 1 + INT( MIN(1.d0, ABS(n(2)/n(1)) ) ) ! Either 1 or 2 only
       c(2) = 3 - c(1) ! Either 1 or 2 only

       s(:) = SIGN(1.d0,n(c(:)))
       b(:) = centroids(c(:),i) * s(:)

       baseiv(:,i) = ivs(:,i) - 1 + s(c(:))

       x(1) = 1
       x(2) = 2
       y(:) = b(2) + (x(:) - b(1))*ABS(n(c(2))/n(c(1)))

       ! Is there a way to avoid this "if"?  Not sure
       sh(:) = 0
       if (y(1)<0 .or. y(2)<0) then
          sh(c(2)) = -s(2) ! Slide stencil down to avoid extrapolating, push up eb, shift down base later
          b(2) = b(2) + 1
          y(:) = b(2) + (x(:) - b(1))*ABS(n(c(2))/n(c(1)))
       endif

       d(:) = SQRT( (x(:)-b(1))**2 + (y(:)-b(2))**2)

       iv(c(1)) = 1 * s(1) + ivs(c(1),i) - baseiv(c(1),i)
       iv(c(2)) = (1 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (0.5d0 * (y(1)-1.d0) * (y(1)-2.d0)) * d(2)/(d(1)*(d(2)-d(1)))

       iv(c(2)) = (2 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (- y(1) * (y(1)-2.d0))              * d(2)/(d(1)*(d(2)-d(1)))

       iv(c(2)) = (3 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (0.5d0 * y(1) * (y(1)-1.d0))        * d(2)/(d(1)*(d(2)-d(1)))

       iv(c(1)) = 2 * s(1) + ivs(c(1),i) - baseiv(c(1),i)
       iv(c(2)) = (1 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (0.5d0 * (y(2)-1.d0) * (y(2)-2.d0)) * (-d(1)/(d(2)*(d(2)-d(1))))

       iv(c(2)) = (2 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (- y(2) * (y(2)-2.d0))              * (-d(1)/(d(2)*(d(2)-d(1))))

       iv(c(2)) = (3 - 1)*s(2) + ivs(c(2),i) - baseiv(c(2),i)
       stencil(iv(1),iv(2),i) = fac * (0.5d0 * y(2) * (y(2)-1.d0))        * (-d(1)/(d(2)*(d(2)-d(1))))

       stencilB(i) = - fac * (d(2)+d(1))/(d(2)*d(1))

       baseiv(:,i) = baseiv(:,i) + sh(:) ! Shift base down, if required

    enddo

  end subroutine get_bndry_grad_stencil

  subroutine apply_bndry_grad_stencil(dudn, b,&
       u,u_l1,u_l2,u_h1,u_h2, &
       stencil,stencilB,baseiv,num) bind(C,name="apply_bndry_grad_stencil")
    integer, intent(in) :: num
    double precision, intent(inout) :: dudn(num)
    double precision, intent(in   ) :: b(num)
    integer,          intent(in   ) :: u_l1,u_l2,u_h1,u_h2
    double precision, intent(in   ) :: u(u_l1:u_h1,u_l2:u_h2)
    double precision, intent(in   ) :: stencil(0:2,0:2,num)
    double precision, intent(in   ) :: stencilB(num)
    integer,          intent(in   ) :: baseiv(dim,num)

    double precision :: fac
    integer :: i, j, L

    do L=1,num

       i = baseiv(1,L)
       j = baseiv(2,L)

       dudn(L) = b(L) * stencilB(L) &
            + u(i  ,j  ) * stencil(0,0,L) &
            + u(i+1,j  ) * stencil(1,0,L) &
            + u(i+2,j  ) * stencil(2,0,L) &
            + u(i  ,j+1) * stencil(0,1,L) &
            + u(i+1,j+1) * stencil(1,1,L) &
            + u(i+2,j+1) * stencil(2,1,L) &
            + u(i  ,j+2) * stencil(0,2,L) &
            + u(i+1,j+2) * stencil(1,2,L) &
            + u(i+2,j+2) * stencil(2,2,L)
    enddo

  end subroutine apply_bndry_grad_stencil

  subroutine init_phi(&
       phi,phi_l1,phi_l2,phi_h1,phi_h2, &
       lo, hi, plo, dx) bind(C,name="init_phi")

    integer, intent(in) :: phi_l1,phi_l2,phi_h1,phi_h2

    integer, intent(in) :: lo(2),hi(2)

    double precision, intent(inout) :: phi(phi_l1:phi_h1,phi_l2:phi_h2)
    double precision, intent(in   ) :: plo(2), dx(2)

    integer :: i,j
    double precision :: x,y

    do j=lo(2),hi(2)
       y = plo(2) + (j+0.5d0)*dx(2)
       do i=lo(1),hi(1)
          x = plo(1) + (i+0.5d0)*dx(1)
          phi(i,j) = 0.5d0 * (x-0.5d0)**2
       enddo
    enddo

  end subroutine init_phi

end module stencil_test_module


SUBROUTINE S(zin)
  COMPLEX(8), DIMENSION(3,3,3) :: zin
  INTEGER :: m,n
  CALL mltfftsg ( zin, m, n )
END SUBROUTINE

COMPLEX(8), DIMENSION(3,3,3) :: zin
CALL s(zin)
END


SUBROUTINE fmacat(vmfl,acat)
!
! This subroutine sets up an intermediate matrix acat.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:)
 REAL(iwp),INTENT(OUT)::acat(:,:)
 REAL(iwp)::temp(4,4),zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp,three=3.0_iwp
 INTEGER::i,j
 temp=zero
 temp(1,1)=one
 temp(1,2)=-pt5
 temp(1,4)=-pt5
 temp(2,1)=-pt5
 temp(2,2)=one
 temp(2,4)=-pt5
 temp(3,3)=three
 temp(4,1)=-pt5
 temp(4,2)=-pt5
 temp(4,4)=one
 DO i=1,4
   DO j=1,4
     acat(i,j)=vmfl(i)*vmfl(j)
   END DO
 END DO
 acat=temp-acat
RETURN
END SUBROUTINE fmacat


!=============================================================================!
        subroutine g1(v, g1v, nx, dx, optx, xper)
!
!  Take the gradient in the streamwise direction
!  updated to fourth order accurate differencing
!
!=============================================================================!
        use diff
        implicit none

        integer nx, optx
        logical :: xper
        real v(nx), g1v(nx), dx

        real,parameter :: one = 1.0
        real dxinv
        real a, b, c, w
        real gx1, gx2, gx3, gx4, gx5, gx6
!=============================================================================!

        dxinv  = one / dx

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(1)        = ( gx1 * v(nx-3)       + &
                                gx2 * v(nx-2)   + &
                                gx3 * v(nx-1)   + &
                                gx4 * v(2)      + &
                                gx5 * v(3)      + &
                                gx6 * v(4)      )

          g1v(2)        = ( gx1 * v(nx-2)       + &
                                gx2 * v(nx-1)   + &
                                gx3 * v(1)      + &
                                gx4 * v(3)      + &
                                gx5 * v(4)      + &
                                gx6 * v(5)      )

          g1v(3)        = ( gx1 * v(nx-1)       + &
                                gx2 * v(1)      + &
                                gx3 * v(2)      + &
                                gx4 * v(4)      + &
                                gx5 * v(5)      + &
                                gx6 * v(6)      )

          g1v(nx-2)     = ( gx1 * v(nx-5)       + &
                                gx2 * v(nx-4)   + &
                                gx3 * v(nx-3)   + &
                                gx4 * v(nx-1)   + &
                                gx5 * v(1)      + &
                                gx6 * v(2)      )

          g1v(nx-1)     = ( gx1 * v(nx-4)       + &
                                gx2 * v(nx-3)   + &
                                gx3 * v(nx-2)   + &
                                gx4 * v(1)      + &
                                gx5 * v(2)      + &
                                gx6 * v(3)      )

          g1v(nx) = g1v(1)

        else

          g1v(1)      = ( gc1 * v(1)  + &
                              gc2 * v(2)  + &
                              gc3 * v(3)  + &
                              gc4 * v(4)  + &
                              gc5 * v(5)  ) * dxinv

          g1v(2)      = ( gb1 * v(1)  + &
                              gb2 * v(2)  + &
                              gb3 * v(3)  + &
                              gb4 * v(4)  + &
                              gb5 * v(5)  ) * dxinv

          g1v(3)      = ( ga1 * v(1)  + &
                              ga2 * v(2)  + &
                              ga3 * v(4)  + &
                              ga4 * v(5)  ) * dxinv

          g1v(nx-2)   = ( ga1 * v(nx-4)  + &
                              ga2 * v(nx-3)  + &
                              ga3 * v(nx-1)  + &
                              ga4 * v(nx  )  ) * dxinv

          g1v(nx-1)  = -( gb1 * v(nx  )  + &
                              gb2 * v(nx-1)  + &
                              gb3 * v(nx-2)  + &
                              gb4 * v(nx-3)  + &
                              gb5 * v(nx-4)  ) * dxinv

          g1v(nx)    = -( gc1 * v(nx  )  + &
                              gc2 * v(nx-1)  + &
                              gc3 * v(nx-2)  + &
                              gc4 * v(nx-3)  + &
                              gc5 * v(nx-4)  ) * dxinv

        end if

!.... interior

        g1v(4:nx-3)  = ( gx1 * v(1:nx-6)        + &
                             gx2 * v(2:nx-5)    + &
                             gx3 * v(3:nx-4)    + &
                             gx4 * v(5:nx-2)    + &
                             gx5 * v(6:nx-1)    + &
                             gx6 * v(7:nx  )    )

        return
        end


!*==sgees.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGEES + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
!                         VS, LDVS, WORK, LWORK, BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVS, SORT
!       INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       REAL               A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
!      $                   WR( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELECT
!       EXTERNAL           SELECT
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGEES computes for an N-by-N real nonsymmetric matrix A, the
!> eigenvalues, the real Schur form T, and, optionally, the matrix of
!> Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
!>
!> Optionally, it also orders the eigenvalues on the diagonal of the
!> real Schur form so that selected eigenvalues are at the top left.
!> The leading columns of Z then form an orthonormal basis for the
!> invariant subspace corresponding to the selected eigenvalues.
!>
!> A matrix is in real Schur form if it is upper quasi-triangular with
!> 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
!> form
!>         [  a  b  ]
!>         [  c  a  ]
!>
!> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVS
!> \verbatim
!>          JOBVS is CHARACTER*1
!>          = 'N': Schur vectors are not computed;
!>          = 'V': Schur vectors are computed.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the Schur form.
!>          = 'N': Eigenvalues are not ordered;
!>          = 'S': Eigenvalues are ordered (see SELECT).
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is a LOGICAL FUNCTION of two REAL arguments
!>          SELECT must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'S', SELECT is used to select eigenvalues to sort
!>          to the top left of the Schur form.
!>          If SORT = 'N', SELECT is not referenced.
!>          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
!>          SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
!>          conjugate pair of eigenvalues is selected, then both complex
!>          eigenvalues are selected.
!>          Note that a selected complex eigenvalue may no longer
!>          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
!>          ordering may change the value of complex eigenvalues
!>          (especially if the eigenvalue is ill-conditioned); in this
!>          case INFO is set to N+2 (see INFO below).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A has been overwritten by its real Schur form T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!>                         for which SELECT is true. (Complex conjugate
!>                         pairs for which SELECT is true for either
!>                         eigenvalue count as 2.)
!> \endverbatim
!>
!> \param[out] WR
!> \verbatim
!>          WR is REAL array, dimension (N)
!> \endverbatim
!>
!> \param[out] WI
!> \verbatim
!>          WI is REAL array, dimension (N)
!>          WR and WI contain the real and imaginary parts,
!>          respectively, of the computed eigenvalues in the same order
!>          that they appear on the diagonal of the output Schur form T.
!>          Complex conjugate pairs of eigenvalues will appear
!>          consecutively with the eigenvalue having the positive
!>          imaginary part first.
!> \endverbatim
!>
!> \param[out] VS
!> \verbatim
!>          VS is REAL array, dimension (LDVS,N)
!>          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
!>          vectors.
!>          If JOBVS = 'N', VS is not referenced.
!> \endverbatim
!>
!> \param[in] LDVS
!> \verbatim
!>          LDVS is INTEGER
!>          The leading dimension of the array VS.  LDVS >= 1; if
!>          JOBVS = 'V', LDVS >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,3*N).
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>          > 0: if INFO = i, and i is
!>             <= N: the QR algorithm failed to compute all the
!>                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
!>                   contain those eigenvalues which have converged; if
!>                   JOBVS = 'V', VS contains the matrix which reduces A
!>                   to its partially converged Schur form.
!>             = N+1: the eigenvalues could not be reordered because some
!>                   eigenvalues were too close to separate (the problem
!>                   is very ill-conditioned);
!>             = N+2: after reordering, roundoff changed values of some
!>                   complex eigenvalues so that leading eigenvalues in
!>                   the Schur form no longer satisfy SELECT=.TRUE.  This
!>                   could also be caused by underflow due to scaling.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup realGEeigen
!
!  =====================================================================
      SUBROUTINE SGEES(Jobvs,Sort,SELECT,N,A,Lda,Sdim,Wr,Wi,Vs,Ldvs,    &
     &                 Work,Lwork,Bwork,Info)
      IMPLICIT NONE
!*--SGEES220
!
!  -- LAPACK driver routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      CHARACTER Jobvs , Sort
      INTEGER Info , Lda , Ldvs , Lwork , N , Sdim
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      REAL A(Lda,*) , Vs(Ldvs,*) , Wi(*) , Work(*) , Wr(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELECT
      EXTERNAL SELECT
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      LOGICAL cursl , lastsl , lquery , lst2sl , scalea , wantst ,      &
     &        wantvs
      INTEGER hswork , i , i1 , i2 , ibal , icond , ierr , ieval , ihi ,&
     &        ilo , inxt , ip , itau , iwrk , maxwrk , minwrk
      REAL anrm , bignum , cscale , eps , s , sep , smlnum
!     ..
!     .. Local Arrays ..
      INTEGER idum(1)
      REAL dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SGEBAK , SGEBAL , SGEHRD , SHSEQR , SLABAD ,     &
     &         SLACPY , SLASCL , SORGHR , SSWAP , STRSEN , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL SLAMCH , SLANGE
      EXTERNAL LSAME , ILAENV , SLAMCH , SLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      wantvs = LSAME(Jobvs,'V')
      wantst = LSAME(Sort,'S')
      IF ( (.NOT.wantvs) .AND. (.NOT.LSAME(Jobvs,'N')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldvs<1 .OR. (wantvs .AND. Ldvs<N) ) THEN
         Info = -11
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by SHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            maxwrk = 1
         ELSE
            maxwrk = 2*N + N*ILAENV(1,'SGEHRD',' ',N,1,N,0)
            minwrk = 3*N
!
            CALL SHSEQR('S',Jobvs,N,1,N,A,Lda,Wr,Wi,Vs,Ldvs,Work,-1,    &
     &                  ieval)
            hswork = Work(1)
!
            IF ( .NOT.wantvs ) THEN
               maxwrk = MAX(maxwrk,N+hswork)
            ELSE
               maxwrk = MAX(maxwrk,2*N+(N-1)                            &
     &                  *ILAENV(1,'SORGHR',' ',N,1,N,-1))
               maxwrk = MAX(maxwrk,N+hswork)
            ENDIF
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -13
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGEES ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = SLAMCH('P')
      smlnum = SLAMCH('S')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = SLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL SLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Permute the matrix to make it more nearly triangular
!     (Workspace: need N)
!
      ibal = 1
      CALL SGEBAL('P',N,A,Lda,ilo,ihi,Work(ibal),ierr)
!
!     Reduce to upper Hessenberg form
!     (Workspace: need 3*N, prefer 2*N+N*NB)
!
      itau = N + ibal
      iwrk = N + itau
      CALL SGEHRD(N,ilo,ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvs ) THEN
!
!        Copy Householder vectors to VS
!
         CALL SLACPY('L',N,N,A,Lda,Vs,Ldvs)
!
!        Generate orthogonal matrix in VS
!        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL SORGHR(N,ilo,ihi,Vs,Ldvs,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
      ENDIF
!
      Sdim = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (Workspace: need N+1, prefer N+HSWORK (see comments) )
!
      iwrk = itau
      CALL SHSEQR('S',Jobvs,N,ilo,ihi,A,Lda,Wr,Wi,Vs,Ldvs,Work(iwrk),   &
     &            Lwork-iwrk+1,ieval)
      IF ( ieval>0 ) Info = ieval
!
!     Sort eigenvalues if desired
!
      IF ( wantst .AND. Info==0 ) THEN
         IF ( scalea ) THEN
            CALL SLASCL('G',0,0,cscale,anrm,N,1,Wr,N,ierr)
            CALL SLASCL('G',0,0,cscale,anrm,N,1,Wi,N,ierr)
         ENDIF
         DO i = 1 , N
            Bwork(i) = SELECT(Wr(i),Wi(i))
         ENDDO
!
!        Reorder eigenvalues and transform Schur vectors
!        (Workspace: none needed)
!
         CALL STRSEN('N',Jobvs,Bwork,N,A,Lda,Vs,Ldvs,Wr,Wi,Sdim,s,sep,  &
     &               Work(iwrk),Lwork-iwrk+1,idum,1,icond)
         IF ( icond>0 ) Info = N + icond
      ENDIF
!
!
!        Undo balancing
!        (Workspace: need N)
!
      IF ( wantvs ) CALL SGEBAK('P','R',N,ilo,ihi,Work(ibal),N,Vs,Ldvs, &
     &                          ierr)
!
      IF ( scalea ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL SLASCL('H',0,0,cscale,anrm,N,N,A,Lda,ierr)
         CALL SCOPY(N,A,Lda+1,Wr,1)
         IF ( cscale==smlnum ) THEN
!
!           If scaling back towards underflow, adjust WI if an
!           offdiagonal element of a 2-by-2 block in the Schur form
!           underflows.
!
            IF ( ieval>0 ) THEN
               i1 = ieval + 1
               i2 = ihi - 1
               CALL SLASCL('G',0,0,cscale,anrm,ilo-1,1,Wi,MAX(ilo-1,1), &
     &                     ierr)
            ELSEIF ( wantst ) THEN
               i1 = 1
               i2 = N - 1
            ELSE
               i1 = ilo
               i2 = ihi - 1
            ENDIF
            inxt = i1 - 1
            DO i = i1 , i2
               IF ( i>=inxt ) THEN
                  IF ( Wi(i)==ZERO ) THEN
                     inxt = i + 1
                  ELSE
                     IF ( A(i+1,i)==ZERO ) THEN
                        Wi(i) = ZERO
                        Wi(i+1) = ZERO
                     ELSEIF ( A(i+1,i)/=ZERO .AND. A(i,i+1)==ZERO ) THEN
                        Wi(i) = ZERO
                        Wi(i+1) = ZERO
                        IF ( i>1 ) CALL SSWAP(i-1,A(1,i),1,A(1,i+1),1)
                        IF ( N>i+1 )                                    &
     &                       CALL SSWAP(N-i-1,A(i,i+2),Lda,A(i+1,i+2),  &
     &                       Lda)
                        IF ( wantvs )                                   &
     &                       CALL SSWAP(N,Vs(1,i),1,Vs(1,i+1),1)
                        A(i,i+1) = A(i+1,i)
                        A(i+1,i) = ZERO
                     ENDIF
                     inxt = i + 2
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
!
!        Undo scaling for the imaginary part of the eigenvalues
!
         CALL SLASCL('G',0,0,cscale,anrm,N-ieval,1,Wi(ieval+1),         &
     &               MAX(N-ieval,1),ierr)
      ENDIF
!
      IF ( wantst .AND. Info==0 ) THEN
!
!        Check if reordering successful
!
         lastsl = .TRUE.
         lst2sl = .TRUE.
         Sdim = 0
         ip = 0
         DO i = 1 , N
            cursl = SELECT(Wr(i),Wi(i))
            IF ( Wi(i)==ZERO ) THEN
               IF ( cursl ) Sdim = Sdim + 1
               ip = 0
               IF ( cursl .AND. .NOT.lastsl ) Info = N + 2
            ELSEIF ( ip==1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
               cursl = cursl .OR. lastsl
               lastsl = cursl
               IF ( cursl ) Sdim = Sdim + 2
               ip = -1
               IF ( cursl .AND. .NOT.lst2sl ) Info = N + 2
            ELSE
!
!                 First eigenvalue of conjugate pair
!
               ip = 1
            ENDIF
            lst2sl = lastsl
            lastsl = cursl
         ENDDO
      ENDIF
!
      Work(1) = maxwrk
!
!     End of SGEES
!
      END SUBROUTINE SGEES