! Fortran 90 code for solving first and second order approximations using
! Schur method.
!
! Code written by Paul Gomme, based on Matlab by Paul Klein
!
! For details see Gomme and Klein: Second-order approximations of dynamic
!                                  models without the use of tensors
!
! Requires LAPACK and LAPACK95; both are included in Intel's MKL.
!=============================================================================
module TOOLS
  interface
     function KRON(x,y)
       use PRECISION
       implicit none
       real(long), dimension(:,:), intent(in) :: x, y
       real(long), dimension(size(x,1)*size(y,1), size(x,2)*size(y,2)) :: KRON
     end function KRON
  end interface

  interface
     function EYE(n)
       use PRECISION
       integer, intent(in) :: n
       real(long), dimension(n,n) :: EYE
     end function eye
  end interface

  interface
     function TRANSP(x)
       use PRECISION
       real(long), dimension(:,:), intent(in) :: x
       real(long), dimension(size(x,1), size(x,2)) :: TRANSP
     end function TRANSP
  end interface

  interface
     function TRACEM(x)
       use PRECISION
       real(long), dimension(:,:), intent(in) :: x
       real(long), dimension(size(x,1)/size(x,2)) :: TRACEM
     end function TRACEM
  end interface

  interface
     function INV(x)
       use PRECISION
       real(long), dimension(:,:), intent(in) :: x
       real(long), dimension(size(x,1),size(x,2)) :: INV
     end function INV
  end interface

  interface
     subroutine SCHUR_FIRST_ORDER(FUNC, x_vec, P, F, Q, NX, NY, info)
       use PRECISION
       real(long), dimension(:), intent(in)    :: x_vec
       real(long), dimension(:,:), intent(out) :: P, F, Q
       integer, intent(in)                     :: NX, NY
       integer, intent(out)                    :: info

       interface
          function FUNC(x)
            use precision
            real(long), dimension(:), intent(in) :: x
            real(long), dimension(size(x)/2)     :: FUNC
          end function FUNC
       end interface
     end subroutine SCHUR_FIRST_ORDER
  end interface

  interface
     subroutine SCHUR_SECOND_ORDER(FUNC, x_vec, Q_mat, F, P, NS, NC, E_mat, &
          & G_mat, sigma, kx, ky, dev)
       use PRECISION
       implicit none
       real(long), dimension(:), intent(in)    :: x_vec
       real(long), dimension(:,:), intent(in)  :: Q_mat, F, P, sigma
       real(long), dimension(:,:), intent(out) :: E_mat, G_mat
       real(long), dimension(:), intent(out)   :: kx, ky
       integer, intent(in)                     :: NS, NC
       real(long), optional, intent(in)        :: dev

       interface
          function FUNC(x)
            use precision
            real(long), dimension(:), intent(in) :: x
            real(long), dimension(size(x)/2)     :: FUNC
          end function FUNC
       end interface
     end subroutine SCHUR_SECOND_ORDER
  end interface
end module TOOLS
!=============================================================================
pure logical function Z_CHOOSE(s,t)
  integer, parameter :: DPC = KIND((1.0D0,1.0D0))
  complex(DPC), intent(in) :: s, t

  if (abs(s) > abs(t)) then
     z_choose = .true.
  else
     z_choose = .false.
  end if
end function Z_CHOOSE
!=============================================================================
subroutine SCHUR_SOLVE(FUNC, x_vec, F_mat, P_mat, NX, NY, sigma, E_mat, G_mat, k_x, k_y, dev, error_code)
  integer, parameter :: long = kind(0.0d0)
  use TOOLS, only : KRON, EYE, TRANSP, TRACEM, INV, SCHUR_FIRST_ORDER, SCHUR_SECOND_ORDER
  use mkl95_lapack, only : GGES, GESV, TGSYL
  implicit none
  real(long), dimension(:), intent(in)    :: x_vec
  real(long), dimension(:,:), intent(out) :: F_mat, P_mat
  real(long), dimension(:,:), optional, intent(in) :: sigma
  real(long), dimension(:,:), optional, intent(out) :: E_mat, G_mat
  real(long), dimension(:), optional, intent(out)   :: k_x, k_y
  integer, intent(in)                     :: NX, NY
  integer, intent(out), optional          :: error_code
  real(long), optional, intent(in)        :: dev

  interface
     function FUNC(x)
       use precision
       real(long), dimension(:), intent(in) :: x
       real(long), dimension(size(x)/2)     :: FUNC
     end function FUNC
  end interface

  real(long), dimension(:,:), allocatable :: Q_mat
  real(long) :: eps
  integer :: info

  allocate(Q_mat(NX+NY,2*(NX+NY)))

  call SCHUR_FIRST_ORDER(FUNC, x_vec, P_mat, F_mat, Q_mat, NX, NY, info)

  if (present(error_code)) error_code = info
  if (info /= 0) return

  if (present(dev)) then
     eps = dev
  else
     eps = 1d-4
  end if

  if (present(sigma) .and. present(E_mat) .and. present(G_mat) &
       & .and. present(k_x) .and. present(k_y)) then
     call SCHUR_SECOND_ORDER(FUNC, x_vec, Q_mat, F_mat, P_mat, NX, NY, &
          & E_mat, G_mat, sigma, k_x, k_y, eps)
  elseif (present(sigma) .or. present(E_mat) .or. present(G_mat) &
       & .or. present(k_x) .or. present(k_y)) then
     print *, 'Second-order solution requires specifying all of:'
     print *, 'E_mat, G_mat, sigma, k_x and k_y.'
  end if

end subroutine SCHUR_SOLVE
!=============================================================================
subroutine SCHUR_FIRST_ORDER(FUNC, x_vec, P, F, Q, NX, NY, error_code)
  integer, parameter :: long = kind(0.0d0)
  use mkl95_lapack, only : GGES, GESV
  implicit none
  real(long), dimension(:), intent(in) :: x_vec
  real(long), dimension(:,:), intent(out) :: P, F, Q
  integer, intent(in) :: NX, NY
  integer, intent(out) :: error_code

  interface
     function FUNC(x)
       use precision
       real(long), dimension(:), intent(in) :: x
       real(long), dimension(size(x)/2)     :: FUNC
     end function FUNC
  end interface

  interface
     pure logical function Z_CHOOSE(s,t)
       integer, parameter :: DPC = KIND((1.0D0,1.0D0))
       complex(DPC), intent(in) :: s, t
     end function Z_CHOOSE
  end interface

  integer, parameter :: DPC = KIND((1.0D0,1.0D0))

  complex(DPC), dimension(:,:), allocatable :: A_C, B_C, vsl, vsr, &
       & S11, T11, Z11, Z21, work1, work2, work3
  complex(DPC), dimension(:), allocatable :: s_vec, t_vec
  real(long), dimension(:), allocatable   :: x1, x2
  real(long)                              :: dx
  real(long), parameter                   :: eps=1d-5
  integer                                 :: i, N, sdim, info

  N = NX+NY

  allocate(x1(2*N), x2(2*N))
  allocate(A_C(N,N), B_C(N,N), vsl(N,N), vsr(N,N), s_vec(N), t_vec(N), &
       & S11(NX,NX), T11(NX,NX), Z11(NX,NX), Z21(NY,NX))

  do i = 1, 2*N
     x1 = x_vec
     x2 = x_vec
     x1(i) = x1(i)*(1d0+eps)+eps
     x2(i) = x2(i)*(1d0-eps)-eps
     dx = x1(i)-x2(i)
     Q(:,i) = (FUNC(x1)-FUNC(x2))/dx
  end do
  B_C = -Q(:,N+1:2*N)
  A_C = Q(:,1:N)

  error_code = 0

  call GGES(A_C, B_C, s_vec, t_vec, vsl, vsr, z_choose, sdim, info)

  if (info == N+2) then
     print *, 'LAPACK: Problem with precision after reordering.'
  else if (info /= 0) then
     print *, 'LAPACK: Problem in Schur decomposition.'
     error_code = 1
     return
  end if

  if (sdim /= NX) then
     write(6,10) NX, sdim, info
     error_code = 2
     return
  end if

10 format(' Economic problem in Schur decomposition' / &
        & ' Number of states:', t40, i5 / &
        & ' Number of correctly ordered elements:', t40, i5 / &
        & ' Value of info from GGES:', t40, i5)

20 format(2(1x,e20.10e3))

  Z11 = vsr(1:NX,1:NX)
  S11 = A_C(1:NX,1:NX)
  T11 = B_C(1:NX,1:NX)
  Z21 = vsr(NX+1:N,1:NX)

  deallocate(A_C, B_C, vsr, vsl, s_vec, t_vec)
  allocate(work1(NX,NX), work2(NX,NX), work3(NX,NX))

  work1 = S11
  work2 = T11
! compute inv(S11)*T11 -- stored in work2
  call GESV(work1, work2, info=info)

! compute inv(Z11) -- stored in work3
  work1 = Z11
  work3 = 0d0
  do i=1,NX
     work3(i,i) = 1d0
  end do
  call GESV(work1, work3, info=info)

  F = DBLE(matmul(Z21,work3))

  P = DBLE(matmul(matmul(Z11,work2),work3))

  deallocate(S11, T11, Z11, Z21)

  if (info /= 0) then
     print *, 'Schur solver: failed.'
  end if
end subroutine SCHUR_FIRST_ORDER
!=============================================================================
! Subroutine: SCHUR_SECOND_ORDER
!
! Purpose: Solves for the second-order accurate approximation
!          of the solution to a dynamic model
!
! The model is E_t[f(x_{t+1},y_{t+1},x_t,y_t)]=0
!
! For the definition of the gradient and the Hessian, see
! Magnus and Neudecker: Matrix Differential Calculus with
! Applications in Statistics and Econometrics.
!
! Outputs:
!   E_mat, G_mat ... matrices of second-order terms
!   kx, ky ......... vectors adjusting constant term
!
! Inputs:
!   FUNC ...... which evaluates the Euler equations and constraints
!   x_vec ..... point around which approximation is computed; consists of:
!               future state variables, future control variables,
!               current state variables, current control variables
!               (in that order, in logarithms)
!   Q_mat ... matrix of first-order partial derivatives
!   F, P .... matrices characterizing the first-order solutions
!        (Q_mat, F and P are computed by first calling SCHUR_FIRST_ORDER)
!   NX ...... number of state variables
!   NY ...... number of control variables
!   sigma ... variance-covariance matrix for the innovations to the
!             state variables
!   dev ..... (optional) the "deviations" used to compute the Hessian matrix
!
! x_{t+1} = kx + Px_t + (1/2)*kron(eye(nx),x'_t)Gx_t + eps_{t+1}
!
! y_{t}   = ky + Fx_t + (1/2)*kron(eye(ny),x'_t)Ex_t
!
! Calls: KRON, EYE, TRANSP, TRACEM, INV, GGES, TGSYL
!
! Original code written by Paul Gomme, based on Matlab by Paul Klein
! Later modifications by Paul Gomme
!
! For details see Gomme and Klein: Second-order approximations of dynamic
!                                  models without the use of tensors
!
subroutine SCHUR_SECOND_ORDER(FUNC, x_vec, Q_mat, F, P, NX, NY, E_mat, &
     & G_mat, sigma, kx, ky, dev)
  integer, parameter :: long = kind(0.0d0)
  use TOOLS, only : KRON, EYE, TRANSP, TRACEM, INV
  use mkl95_lapack, only : GGES, TGSYL
  implicit none
  integer, parameter :: DPC = KIND((1.0D0,1.0D0))
  real(long), dimension(:), intent(in)    :: x_vec
  real(long), dimension(:,:), intent(in)  :: Q_mat, F, P, sigma
  real(long), dimension(:,:), intent(out) :: E_mat, G_mat
  real(long), dimension(:), intent(out)   :: kx, ky
  integer, intent(in)                     :: NX, NY
  real(long), optional, intent(in)        :: dev

  interface
     function FUNC(x)
       use precision
       real(long), dimension(:), intent(in) :: x
       real(long), dimension(size(x)/2)     :: FUNC
     end function FUNC
  end interface

  real(long), dimension(:), allocatable   :: x_prime, feval
  real(long), dimension(:,:), allocatable :: f1, f2, f3, f4
  real(long), dimension(:,:), allocatable :: A_1, B_1, B_2, B_4, C_1, C_2
  real(long), dimension(:,:), allocatable :: Inx, Iny, Im, M_mat
  real(long), dimension(:,:), allocatable :: A_tilde, B_tilde, C_tilde
  real(long), dimension(:,:), allocatable :: D_tilde, E_tilde, F_tilde
  real(long), dimension(:,:), allocatable :: P_1, Q_1, U_1, V_1
  real(long), dimension(:), allocatable   :: alpha_r, alpha_i, beta
  real(long), dimension(:,:), allocatable :: Hess, ma, eyeff
  real(long), dimension(:), allocatable   :: y, kxy, ve
  real(long)                              :: deviation
  integer                                 :: i, j, k, N, M, info

  M = NX+NY
  N = 2*M

  allocate(x_prime(N), feval(M))
  allocate(f1(M,NX), f2(M,NY), f3(M,NX), f4(M,NY))
  allocate(A_1(M*NX,NX), B_1(M*NX,NX*NX))
  allocate(B_2(M*NX,NX*NY), B_4(M*NX,NX*NY))
  ! 2011-04-13: Corrected dimension of C_2
  allocate(C_1(NX*NY,NX*NY), C_2(NX*NY,NX*NX), M_mat(N,NX))
  allocate(A_tilde((NX+NY)*NX,(NX+NY)*NX), D_tilde((NX+NY)*NX,(NX+NY)*NX))
  allocate(B_tilde(NX,NX), E_tilde(NX,NX))
  allocate(C_tilde((NX+NY)*NX,NX), F_tilde((NX+NY)*NX,NX))
  ! 2011-04-13: Added declaration of Im
  allocate(Inx(NX,NX), Iny(NY,NY), Im(M,M))
  allocate(Hess(M*N,N), y(M))
  allocate(ma(M,M), ve(M), kxy(M))

  if (present(dev)) then
     deviation = dev
  else
     deviation = 1d-4
  end if

  feval = FUNC(x_vec)

  do i = 1, N
     x_prime = x_vec
     x_prime(i) = x_prime(i) + deviation
     y = FUNC(x_prime)

     x_prime = x_vec
     x_prime(i) = x_prime(i) - deviation
     y = (y + FUNC(x_prime) - 2d0*feval) / (deviation**2)

     do k = 1, M
        Hess(N*(k-1)+i,i) = y(k)
     end do

     do j = i+1, N
        x_prime = x_vec
        x_prime(i) = x_prime(i) + deviation
        x_prime(j) = x_prime(j) + deviation
        y = FUNC(x_prime)

        x_prime = x_vec
        x_prime(i) = x_prime(i) - deviation
        x_prime(j) = x_prime(j) - deviation
        y = y + FUNC(x_prime)

        x_prime = x_vec
        x_prime(i) = x_prime(i) + deviation
        x_prime(j) = x_prime(j) - deviation
        y = y - FUNC(x_prime)

        x_prime = x_vec
        x_prime(i) = x_prime(i) - deviation
        x_prime(j) = x_prime(j) + deviation
        y = (y - FUNC(x_prime)) / (4d0*deviation**2d0)
        do k = 1, M
           Hess(N*(k-1)+j,i) = y(k)
           Hess(N*(k-1)+i,j) = y(k)
        end do
     end do
  end do

  f1 = Q_mat(:,1:NX)
  f2 = Q_mat(:,NX+1:M)
  f3 = Q_mat(:,M+1:M+NX)
  f4 = Q_mat(:,M+NX+1:2*M)

  Inx = EYE(NX)
  Iny = EYE(NY)
  Im = EYE(M)

  M_mat(1:NX,:) = P
  M_mat(NX+1:M,:) = matmul(F,P)
  M_mat(M+1:M+NX,:) = Inx
  M_mat(M+NX+1:2*M,:) = F

  A_1 = MATMUL(KRON(Im,transpose(M_mat)), MATMUL(Hess,M_mat))

  B_1 = KRON(f1,Inx)
  B_2 = KRON(f2,Inx)
  B_4 = KRON(f4,Inx)

  C_1 = KRON(Iny,transpose(P))
  C_2 = KRON(F,Inx)

  ! Code to solve Sylvester equation (with lots of setup). 2010-04-20

  A_tilde(:,1:NX*NY) = B_4
  A_tilde(:,NX*NY+1:NX*(NX+NY)) = B_1 + matmul(B_2,C_2)
  B_tilde = -P
  C_tilde = -A_1
  D_tilde = 0d0
  D_tilde(:,1:NX*NY) = matmul(B_2,C_1)
  E_tilde = Inx
  F_tilde = 0d0

  ! Need to put (A_tilde,D_tilde) into generalized Schur form
  allocate(alpha_r((NX+NY)*NX), alpha_i((NX+NY)*NX), beta((NX+NY)*NX))
  allocate(P_1(M*NX,M*NX), Q_1(M*NX,M*NX))

  call GGES(A_tilde, D_tilde, alpha_r, alpha_i, beta, P_1, Q_1, info=info)

  deallocate(alpha_r,alpha_i,beta)

  ! Need to put (B_tilde,E_tilde) into generalized Schur form
  allocate(alpha_r(NX), alpha_i(NX), beta(NX))
  allocate(U_1(NX,NX), V_1(NX,NX))

  call GGES(B_tilde, E_tilde, alpha_r, alpha_i, beta, U_1, V_1, info=info)

  deallocate(alpha_r,alpha_i,beta)

  C_tilde = matmul(transpose(P_1), matmul(C_tilde,V_1))
  F_tilde = matmul(transpose(P_1), matmul(F_tilde,V_1))

  ! Solve the generalized Sylvester equation
  call TGSYL(A_tilde, B_tilde, C_tilde, D_tilde, E_tilde, F_tilde, info=info)

  C_tilde = matmul(matmul(Q_1,C_tilde), transpose(V_1))

  E_mat = C_tilde(1:NX*NY,:)
  G_mat = C_tilde(NX*NY+1:NX*NX*NY,:)

  ma(:,1:NX) = f1 + matmul(f2,F)
  ma(:,NX+1:M) = f2 + f4
  ma = 2d0*ma

  allocate(eyeff(2*M,NX)) ! 2009-09-21

  eyeff = 0d0 ! 2009-09-21
  eyeff(1:NX,:) = Inx ! 2009-09-21
  do i = 1, NY
     eyeff(NX+i,:) = F(i,:) ! 2009-09-21
  end do

! 2009-09-21
  ve = matmul(f2, TRACEM(matmul(KRON(Iny,sigma), E_mat))) &
       & + TRACEM(matmul(matmul(KRON(Im,transpose(eyeff)),Hess), &
       & matmul(eyeff,sigma)))

  kxy = -matmul(INV(ma), ve)
  kx = kxy(1:NX)
  ky = kxy(NX+1:NX+NY)

  deallocate(x_prime, feval)
  deallocate(f1, f2, f3, f4, A_1, B_1, B_2, B_4, C_1, C_2, M_mat)
  deallocate(A_tilde, B_tilde, C_tilde, D_tilde, E_tilde, F_tilde)
  deallocate(Inx, Iny)
  deallocate(Hess, y, ma, ve, kxy)
end subroutine SCHUR_SECOND_ORDER
!=============================================================================
function TRACEM(x)
  integer, parameter :: long = kind(0.0d0)
  use TOOLS, only : TRACE
  implicit none
  real(long), dimension(:,:), intent(in) :: x
  real(long), dimension(size(x,1)/size(x,2)) :: TRACEM
  integer :: n, m, i

  n = size(x,2)
  m = size(x,1)/n

  do i = 1, m
     TRACEM(i) = TRACE(x((n*(i-1)+1):i*N,:))
  end do
end function TRACEM
!=============================================================================
function TRACE(x)
  integer, parameter :: long = kind(0.0d0)
  implicit none
  real(long), dimension(:,:), intent(in) :: x
  real(long) :: TRACE
  integer :: n, i

  n = size(x,1)

  TRACE = 0d0
  do i = 1, n
     TRACE = TRACE + x(i,i)
  end do
end function TRACE
!=============================================================================
function TRANSP(x)
  integer, parameter :: long = kind(0.0d0)
  implicit none
  real(long), dimension(:,:), intent(in) :: x
  real(long), dimension(size(x,1), size(x,2)) :: TRANSP
  integer :: i, n, m

  n = size(x,2)
  m = size(x,1)/n

  do i = 1, m
     TRANSP((n*(i-1)+1):i*n,1:n) = transpose(x((n*(i-1)+1):i*n,1:n))
  end do
end function TRANSP
!=============================================================================
function DET(q)
  integer, parameter :: long = kind(0.0d0)
  use mkl95_lapack, only : GETRF
  implicit none
  real(long), dimension(:,:), intent(in) :: q
!  real(long), dimension(1,1) :: DET
  real(long) :: DET
  real(long), dimension(:,:), allocatable :: a
  integer :: N, info, i
  integer, dimension(:), allocatable :: ipiv

  N = size(q,1)
  allocate(a(N,N), ipiv(N))
  a(:,:) = q(:,:)
  call GETRF(a, IPIV=ipiv, INFO=info)
  if (info .ne. 0) then
     print *, 'DET: problem in return from DGETRF.'
     DET = 0d0
  else
     DET = 1d0
     do i = 1, N
        DET = DET*a(i,i)
        if (i /= ipiv(i)) DET = -DET
     end do
  end if
end function DET
!=============================================================================
function EYE(n)
  integer, parameter :: long = kind(0.0d0)
  implicit none
  integer, intent(in) :: n
  real(long), dimension(n,n) :: EYE
  integer :: i

  EYE(:,:) = 0d0
  do i = 1, n
     EYE(i,i) = 1d0
  end do
end function EYE
!=============================================================================
function KRON(x,y)
  integer, parameter :: long = kind(0.0d0)
  implicit none
  real(long), dimension(:,:), intent(in) :: x, y
  real(long), dimension(size(x,1)*size(y,1), size(x,2)*size(y,2)) :: KRON
  integer :: NX1, NX2, NY1, NY2, ix1, ix2, iy1, iy2, iz1, iz2

  NX1 = size(x,1)
  NX2 = size(x,2)
  NY1 = size(y,1)
  NY2 = size(y,2)

  do ix1 = 1, NX1
     do ix2 = 1, NX2
        do iy1 = 1, NY1
           do iy2 = 1, NY2
              iz1 = (ix1-1)*NY1 + iy1
              iz2 = (ix2-1)*NY2 + iy2
              KRON(iz1,iz2) = x(ix1,ix2)*y(iy1,iy2)
           end do
        end do
     end do
  end do
end function KRON
!=============================================================================
function INV(x)
  integer, parameter :: long = kind(0.0d0)
  use mkl95_lapack, only : GESV
  implicit none
  real(long), dimension(:,:), intent(in) :: x
  real(long), dimension(size(x,1),size(x,2)) :: INV
  integer, dimension(:), allocatable :: indx
  real(long), dimension(:,:), allocatable :: y
  integer :: info, i, N

  if (size(x,1) .ne. size(x,2)) then
     print *, 'INV: Matrix must be square.'
     return
  end if

  N = size(x,1)
  allocate(indx(N), y(N,N))

  INV(:,:) = x(:,:)

  y(:,:) = 0d0
  do i = 1, N
     y(i,i) = 1d0
  end do

  call GESV(INV, y, INFO=info)

  if (info .ne. 0) then
     print *, 'INV: problem in call to DGESV'
  end if

  INV = y
end function INV


c
c-----------------------------------------------------------------------
c subroutine:  ffa
c fast fourier analysis subroutine
c-----------------------------------------------------------------------
c
      subroutine ffa (b, nfft, ier)
c
c this subroutine replaces the real vector b(k),  (k=1,2,...,n),
c with its finite discrete fourier transform.  the dc term is
c returned in location b(1) with b(2) set to 0.  thereafter, the
c jth harmonic is returned as a complex number stored as
c b(2*j+1) + i b(2*j+2).  note that the n/2 harmonic is returned
c in b(n+1) with b(n+2) set to 0.  hence, b must be dimensioned
c to size n+2.
c subroutine is called as ffa (b,n) where n=2**m and b is an
c n term real array.  a real-valued, radix 8  algorithm is used
c with in-place reordering and the trig functions are computed as
c needed.
c
      dimension b(2)
      common /con/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
c+noao
c      iw = i1mach(2)
      ier = 0
c-noao
c
      pii = 4.*atan(1.)
      pi8 = pii/8.
      p7 = 1./sqrt(2.)
      p7two = 2.*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.*pii
      n = 1
      do 10 i=1,31
        m = i
        n = n*2
        if (n.eq.nfft) go to 20
  10  continue
c+noao
c      write (iw,9999)
c9999  format (30h nfft not a power of 2 for ffa)
c      stop
       ier = 1
       return
c-noao
  20  continue
      n8pow = m/3
c
c do a radix 2 or radix 4 iteration first if one is required
c
      if (m-n8pow*3-1) 50, 40, 30
  30  nn = 4
      int = n/nn
      call r4tr(int, b(1), b(int+1), b(2*int+1), b(3*int+1))
      go to 60
  40  nn = 2
      int = n/nn
      call r2tr(int, b(1), b(int+1))
      go to 60
  50  nn = 1
c
c perform radix 8 iterations
c
  60  if (n8pow) 90, 90, 70
  70  do 80 it=1,n8pow
        nn = nn*8
        int = n/nn
        call r8tr(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1),
     *      b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1),
     *      b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1),
     *      b(6*int+1), b(7*int+1))
  80  continue
c
c perform in-place reordering
c
  90  call ord1(m, b)
      call ord2(m, b)
      t = b(2)
      b(2) = 0.
      b(nfft+1) = t
      b(nfft+2) = 0.
      do 100 i=4,nfft,2
        b(i) = -b(i)
 100  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  ffs
c fast fourier synthesis subroutine
c radix 8-4-2
c-----------------------------------------------------------------------
c
      subroutine ffs (b, nfft, ier)
c
c this subroutine synthesizes the real vector b(k), where
c k=1,2,...,n. the initial fourier coefficients are placed in
c the b array of size n+2.  the dc term is in b(1) with
c b(2) equal to 0.
c the jth harmonic is stored as b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0.
c the subroutine is called as ffs(b,n) where n=2**m and
c b is the n term real array discussed above.
c
      dimension b(2)
      common /con1/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
c+noao
c      iw = i1mach(2)
      ier = 0
c-noao
c
      pii = 4.*atan(1.)
      pi8 = pii/8.
      p7 = 1./sqrt(2.)
      p7two = 2.*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.*pii
      n = 1
      do 10 i=1,31
        m = i
        n = n*2
        if (n.eq.nfft) go to 20
  10  continue
c+noao
c      write (iw,9999)
c9999  format (30h nfft not a power of 2 for ffs)
c      stop
      ier = 1
      return
c-noao
  20  continue
      b(2) = b(nfft+1)
      do 30 i=1,nfft
        b(i) = b(i)/float(nfft)
  30  continue
      do 40 i=4,nfft,2
        b(i) = -b(i)
  40  continue
      n8pow = m/3
c
c reorder the input fourier coefficients
c
      call ord2(m, b)
      call ord1(m, b)
c
      if (n8pow.eq.0) go to 60
c
c perform the radix 8 iterations
c
      nn = n
      do 50 it=1,n8pow
        int = n/nn
        call r8syn(int, nn, b, b(int+1), b(2*int+1), b(3*int+1),
     *      b(4*int+1), b(5*int+1), b(6*int+1), b(7*int+1), b(1),
     *      b(int+1), b(2*int+1), b(3*int+1), b(4*int+1), b(5*int+1),
     *      b(6*int+1), b(7*int+1))
        nn = nn/8
  50  continue
c
c do a radix 2 or radix 4 iteration if one is required
c
  60  if (m-n8pow*3-1) 90, 80, 70
  70  int = n/4
      call r4syn(int, b(1), b(int+1), b(2*int+1), b(3*int+1))
      go to 90
  80  int = n/2
      call r2tr(int, b(1), b(int+1))
  90  return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r2tr
c radix 2 iteration subroutine
c-----------------------------------------------------------------------
c
c
      subroutine r2tr(int, b0, b1)
      dimension b0(2), b1(2)
      do 10 k=1,int
        t = b0(k) + b1(k)
        b1(k) = b0(k) - b1(k)
        b0(k) = t
  10  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r4tr
c radix 4 iteration subroutine
c-----------------------------------------------------------------------
c
      subroutine r4tr(int, b0, b1, b2, b3)
      dimension b0(2), b1(2), b2(2), b3(2)
      do 10 k=1,int
        r0 = b0(k) + b2(k)
        r1 = b1(k) + b3(k)
        b2(k) = b0(k) - b2(k)
        b3(k) = b1(k) - b3(k)
        b0(k) = r0 + r1
        b1(k) = r0 - r1
  10  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine: r8tr
c radix 8 iteration subroutine
c-----------------------------------------------------------------------
c
      subroutine r8tr(int, nn, br0, br1, br2, br3, br4, br5, br6, br7,
     *    bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7)
      dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2),
     *    br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2),
     *    bi5(2), bi6(2), bi7(2)
      common /con/ pii, p7, p7two, c22, s22, pi2
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
c
c set up counters such that jthet steps through the arguments
c of w, jr steps through starting locations for the real part of the
c intermediate results and ji steps through starting locations
c of the imaginary part of the intermediate results.
c
      l(1) = nn/8
      do 40 k=2,15
        if (l(k-1)-2) 10, 20, 30
  10    l(k-1) = 2
  20    l(k) = 2
        go to 40
  30    l(k) = l(k-1)/2
  40  continue
      piovn = pii/float(nn)
      ji = 3
      jl = 2
      jr = 2
      do 120 j1=2,l1,2
      do 120 j2=j1,l2,l1
      do 120 j3=j2,l3,l2
      do 120 j4=j3,l4,l3
      do 120 j5=j4,l5,l4
      do 120 j6=j5,l6,l5
      do 120 j7=j6,l7,l6
      do 120 j8=j7,l8,l7
      do 120 j9=j8,l9,l8
      do 120 j10=j9,l10,l9
      do 120 j11=j10,l11,l10
      do 120 j12=j11,l12,l11
      do 120 j13=j12,l13,l12
      do 120 j14=j13,l14,l13
      do 120 jthet=j14,l15,l14
        th2 = jthet - 2
        if (th2) 50, 50, 90
  50    do 60 k=1,int
          t0 = br0(k) + br4(k)
          t1 = br1(k) + br5(k)
          t2 = br2(k) + br6(k)
          t3 = br3(k) + br7(k)
          t4 = br0(k) - br4(k)
          t5 = br1(k) - br5(k)
          t6 = br2(k) - br6(k)
          t7 = br3(k) - br7(k)
          br2(k) = t0 - t2
          br3(k) = t1 - t3
          t0 = t0 + t2
          t1 = t1 + t3
          br0(k) = t0 + t1
          br1(k) = t0 - t1
          pr = p7*(t5-t7)
          pi = p7*(t5+t7)
          br4(k) = t4 + pr
          br7(k) = t6 + pi
          br6(k) = t4 - pr
          br5(k) = pi - t6
  60    continue
        if (nn-8) 120, 120, 70
  70    k0 = int*8 + 1
        kl = k0 + int - 1
        do 80 k=k0,kl
          pr = p7*(bi2(k)-bi6(k))
          pi = p7*(bi2(k)+bi6(k))
          tr0 = bi0(k) + pr
          ti0 = bi4(k) + pi
          tr2 = bi0(k) - pr
          ti2 = bi4(k) - pi
          pr = p7*(bi3(k)-bi7(k))
          pi = p7*(bi3(k)+bi7(k))
          tr1 = bi1(k) + pr
          ti1 = bi5(k) + pi
          tr3 = bi1(k) - pr
          ti3 = bi5(k) - pi
          pr = tr1*c22 - ti1*s22
          pi = ti1*c22 + tr1*s22
          bi0(k) = tr0 + pr
          bi6(k) = tr0 - pr
          bi7(k) = ti0 + pi
          bi1(k) = pi - ti0
          pr = -tr3*s22 - ti3*c22
          pi = tr3*c22 - ti3*s22
          bi2(k) = tr2 + pr
          bi4(k) = tr2 - pr
          bi5(k) = ti2 + pi
          bi3(k) = pi - ti2
  80    continue
        go to 120
  90    arg = th2*piovn
        c1 = cos(arg)
        s1 = sin(arg)
        c2 = c1**2 - s1**2
        s2 = c1*s1 + c1*s1
        c3 = c1*c2 - s1*s2
        s3 = c2*s1 + s2*c1
        c4 = c2**2 - s2**2
        s4 = c2*s2 + c2*s2
        c5 = c2*c3 - s2*s3
        s5 = c3*s2 + s3*c2
        c6 = c3**2 - s3**2
        s6 = c3*s3 + c3*s3
        c7 = c3*c4 - s3*s4
        s7 = c4*s3 + s4*c3
        int8 = int*8
        j0 = jr*int8 + 1
        k0 = ji*int8 + 1
        jlast = j0 + int - 1
        do 100 j=j0,jlast
          k = k0 + j - j0
          tr1 = br1(j)*c1 - bi1(k)*s1
          ti1 = br1(j)*s1 + bi1(k)*c1
          tr2 = br2(j)*c2 - bi2(k)*s2
          ti2 = br2(j)*s2 + bi2(k)*c2
          tr3 = br3(j)*c3 - bi3(k)*s3
          ti3 = br3(j)*s3 + bi3(k)*c3
          tr4 = br4(j)*c4 - bi4(k)*s4
          ti4 = br4(j)*s4 + bi4(k)*c4
          tr5 = br5(j)*c5 - bi5(k)*s5
          ti5 = br5(j)*s5 + bi5(k)*c5
          tr6 = br6(j)*c6 - bi6(k)*s6
          ti6 = br6(j)*s6 + bi6(k)*c6
          tr7 = br7(j)*c7 - bi7(k)*s7
          ti7 = br7(j)*s7 + bi7(k)*c7
c
          t0 = br0(j) + tr4
          t1 = bi0(k) + ti4
          tr4 = br0(j) - tr4
          ti4 = bi0(k) - ti4
          t2 = tr1 + tr5
          t3 = ti1 + ti5
          tr5 = tr1 - tr5
          ti5 = ti1 - ti5
          t4 = tr2 + tr6
          t5 = ti2 + ti6
          tr6 = tr2 - tr6
          ti6 = ti2 - ti6
          t6 = tr3 + tr7
          t7 = ti3 + ti7
          tr7 = tr3 - tr7
          ti7 = ti3 - ti7
c
          tr0 = t0 + t4
          ti0 = t1 + t5
          tr2 = t0 - t4
          ti2 = t1 - t5
          tr1 = t2 + t6
          ti1 = t3 + t7
          tr3 = t2 - t6
          ti3 = t3 - t7
          t0 = tr4 - ti6
          t1 = ti4 + tr6
          t4 = tr4 + ti6
          t5 = ti4 - tr6
          t2 = tr5 - ti7
          t3 = ti5 + tr7
          t6 = tr5 + ti7
          t7 = ti5 - tr7
          br0(j) = tr0 + tr1
          bi7(k) = ti0 + ti1
          bi6(k) = tr0 - tr1
          br1(j) = ti1 - ti0
          br2(j) = tr2 - ti3
          bi5(k) = ti2 + tr3
          bi4(k) = tr2 + ti3
          br3(j) = tr3 - ti2
          pr = p7*(t2-t3)
          pi = p7*(t2+t3)
          br4(j) = t0 + pr
          bi3(k) = t1 + pi
          bi2(k) = t0 - pr
          br5(j) = pi - t1
          pr = -p7*(t6+t7)
          pi = p7*(t6-t7)
          br6(j) = t4 + pr
          bi1(k) = t5 + pi
          bi0(k) = t4 - pr
          br7(j) = pi - t5
 100    continue
        jr = jr + 2
        ji = ji - 2
        if (ji-jl) 110, 110, 120
 110    ji = 2*jr - 1
        jl = jr
 120  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r4syn
c radix 4 synthesis
c-----------------------------------------------------------------------
c
      subroutine r4syn(int, b0, b1, b2, b3)
      dimension b0(2), b1(2), b2(2), b3(2)
      do 10 k=1,int
        t0 = b0(k) + b1(k)
        t1 = b0(k) - b1(k)
        t2 = b2(k) + b2(k)
        t3 = b3(k) + b3(k)
        b0(k) = t0 + t2
        b2(k) = t0 - t2
        b1(k) = t1 + t3
        b3(k) = t1 - t3
  10  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r8syn
c radix 8 synthesis subroutine
c-----------------------------------------------------------------------
c
      subroutine r8syn(int, nn, br0, br1, br2, br3, br4, br5, br6, br7,
     *    bi0, bi1, bi2, bi3, bi4, bi5, bi6, bi7)
      dimension l(15), br0(2), br1(2), br2(2), br3(2), br4(2), br5(2),
     *    br6(2), br7(2), bi0(2), bi1(2), bi2(2), bi3(2), bi4(2),
     *    bi5(2), bi6(2), bi7(2)
      common /con1/ pii, p7, p7two, c22, s22, pi2
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
      l(1) = nn/8
      do 40 k=2,15
        if (l(k-1)-2) 10, 20, 30
  10    l(k-1) = 2
  20    l(k) = 2
        go to 40
  30    l(k) = l(k-1)/2
  40  continue
      piovn = pii/float(nn)
      ji = 3
      jl = 2
      jr = 2
c
      do 120 j1=2,l1,2
      do 120 j2=j1,l2,l1
      do 120 j3=j2,l3,l2
      do 120 j4=j3,l4,l3
      do 120 j5=j4,l5,l4
      do 120 j6=j5,l6,l5
      do 120 j7=j6,l7,l6
      do 120 j8=j7,l8,l7
      do 120 j9=j8,l9,l8
      do 120 j10=j9,l10,l9
      do 120 j11=j10,l11,l10
      do 120 j12=j11,l12,l11
      do 120 j13=j12,l13,l12
      do 120 j14=j13,l14,l13
      do 120 jthet=j14,l15,l14
        th2 = jthet - 2
        if (th2) 50, 50, 90
  50    do 60 k=1,int
          t0 = br0(k) + br1(k)
          t1 = br0(k) - br1(k)
          t2 = br2(k) + br2(k)
          t3 = br3(k) + br3(k)
          t4 = br4(k) + br6(k)
          t6 = br7(k) - br5(k)
          t5 = br4(k) - br6(k)
          t7 = br7(k) + br5(k)
          pr = p7*(t7+t5)
          pi = p7*(t7-t5)
          tt0 = t0 + t2
          tt1 = t1 + t3
          t2 = t0 - t2
          t3 = t1 - t3
          t4 = t4 + t4
          t5 = pr + pr
          t6 = t6 + t6
          t7 = pi + pi
          br0(k) = tt0 + t4
          br1(k) = tt1 + t5
          br2(k) = t2 + t6
          br3(k) = t3 + t7
          br4(k) = tt0 - t4
          br5(k) = tt1 - t5
          br6(k) = t2 - t6
          br7(k) = t3 - t7
  60    continue
        if (nn-8) 120, 120, 70
  70    k0 = int*8 + 1
        kl = k0 + int - 1
        do 80 k=k0,kl
          t1 = bi0(k) + bi6(k)
          t2 = bi7(k) - bi1(k)
          t3 = bi0(k) - bi6(k)
          t4 = bi7(k) + bi1(k)
          pr = t3*c22 + t4*s22
          pi = t4*c22 - t3*s22
          t5 = bi2(k) + bi4(k)
          t6 = bi5(k) - bi3(k)
          t7 = bi2(k) - bi4(k)
          t8 = bi5(k) + bi3(k)
          rr = t8*c22 - t7*s22
          ri = -t8*s22 - t7*c22
          bi0(k) = (t1+t5) + (t1+t5)
          bi4(k) = (t2+t6) + (t2+t6)
          bi1(k) = (pr+rr) + (pr+rr)
          bi5(k) = (pi+ri) + (pi+ri)
          t5 = t1 - t5
          t6 = t2 - t6
          bi2(k) = p7two*(t6+t5)
          bi6(k) = p7two*(t6-t5)
          rr = pr - rr
          ri = pi - ri
          bi3(k) = p7two*(ri+rr)
          bi7(k) = p7two*(ri-rr)
  80    continue
        go to 120
  90    arg = th2*piovn
        c1 = cos(arg)
        s1 = -sin(arg)
        c2 = c1**2 - s1**2
        s2 = c1*s1 + c1*s1
        c3 = c1*c2 - s1*s2
        s3 = c2*s1 + s2*c1
        c4 = c2**2 - s2**2
        s4 = c2*s2 + c2*s2
        c5 = c2*c3 - s2*s3
        s5 = c3*s2 + s3*c2
        c6 = c3**2 - s3**2
        s6 = c3*s3 + c3*s3
        c7 = c3*c4 - s3*s4
        s7 = c4*s3 + s4*c3
        int8 = int*8
        j0 = jr*int8 + 1
        k0 = ji*int8 + 1
        jlast = j0 + int - 1
        do 100 j=j0,jlast
          k = k0 + j - j0
          tr0 = br0(j) + bi6(k)
          ti0 = bi7(k) - br1(j)
          tr1 = br0(j) - bi6(k)
          ti1 = bi7(k) + br1(j)
          tr2 = br2(j) + bi4(k)
          ti2 = bi5(k) - br3(j)
          tr3 = bi5(k) + br3(j)
          ti3 = bi4(k) - br2(j)
          tr4 = br4(j) + bi2(k)
          ti4 = bi3(k) - br5(j)
          t0 = br4(j) - bi2(k)
          t1 = bi3(k) + br5(j)
          tr5 = p7*(t0+t1)
          ti5 = p7*(t1-t0)
          tr6 = br6(j) + bi0(k)
          ti6 = bi1(k) - br7(j)
          t0 = br6(j) - bi0(k)
          t1 = bi1(k) + br7(j)
          tr7 = -p7*(t0-t1)
          ti7 = -p7*(t1+t0)
          t0 = tr0 + tr2
          t1 = ti0 + ti2
          t2 = tr1 + tr3
          t3 = ti1 + ti3
          tr2 = tr0 - tr2
          ti2 = ti0 - ti2
          tr3 = tr1 - tr3
          ti3 = ti1 - ti3
          t4 = tr4 + tr6
          t5 = ti4 + ti6
          t6 = tr5 + tr7
          t7 = ti5 + ti7
          ttr6 = ti4 - ti6
          ti6 = tr6 - tr4
          ttr7 = ti5 - ti7
          ti7 = tr7 - tr5
          br0(j) = t0 + t4
          bi0(k) = t1 + t5
          br1(j) = c1*(t2+t6) - s1*(t3+t7)
          bi1(k) = c1*(t3+t7) + s1*(t2+t6)
          br2(j) = c2*(tr2+ttr6) - s2*(ti2+ti6)
          bi2(k) = c2*(ti2+ti6) + s2*(tr2+ttr6)
          br3(j) = c3*(tr3+ttr7) - s3*(ti3+ti7)
          bi3(k) = c3*(ti3+ti7) + s3*(tr3+ttr7)
          br4(j) = c4*(t0-t4) - s4*(t1-t5)
          bi4(k) = c4*(t1-t5) + s4*(t0-t4)
          br5(j) = c5*(t2-t6) - s5*(t3-t7)
          bi5(k) = c5*(t3-t7) + s5*(t2-t6)
          br6(j) = c6*(tr2-ttr6) - s6*(ti2-ti6)
          bi6(k) = c6*(ti2-ti6) + s6*(tr2-ttr6)
          br7(j) = c7*(tr3-ttr7) - s7*(ti3-ti7)
          bi7(k) = c7*(ti3-ti7) + s7*(tr3-ttr7)
 100    continue
        jr = jr + 2
        ji = ji - 2
        if (ji-jl) 110, 110, 120
 110    ji = 2*jr - 1
        jl = jr
 120  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  ord1
c in-place reordering subroutine
c-----------------------------------------------------------------------
c
      subroutine ord1(m, b)
      dimension b(2)
c
      k = 4
      kl = 2
      n = 2**m
      do 40 j=4,n,2
        if (k-j) 20, 20, 10
  10    t = b(j)
        b(j) = b(k)
        b(k) = t
  20    k = k - 2
        if (k-kl) 30, 30, 40
  30    k = 2*j
        kl = j
  40  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  ord2
c in-place reordering subroutine
c-----------------------------------------------------------------------
c
      subroutine ord2(m, b)
      dimension l(15), b(2)
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
      n = 2**m
      l(1) = n
      do 10 k=2,m
        l(k) = l(k-1)/2
  10  continue
      do 20 k=m,14
        l(k+1) = 2
  20  continue
      ij = 2
      do 40 j1=2,l1,2
      do 40 j2=j1,l2,l1
      do 40 j3=j2,l3,l2
      do 40 j4=j3,l4,l3
      do 40 j5=j4,l5,l4
      do 40 j6=j5,l6,l5
      do 40 j7=j6,l7,l6
      do 40 j8=j7,l8,l7
      do 40 j9=j8,l9,l8
      do 40 j10=j9,l10,l9
      do 40 j11=j10,l11,l10
      do 40 j12=j11,l12,l11
      do 40 j13=j12,l13,l12
      do 40 j14=j13,l14,l13
      do 40 ji=j14,l15,l14
        if (ij-ji) 30, 40, 40
  30    t = b(ij-1)
        b(ij-1) = b(ji-1)
        b(ji-1) = t
        t = b(ij)
        b(ij) = b(ji)
        b(ji) = t
  40    ij = ij + 2
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: mcsqf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER)
      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(LOT,*)
      IER = 0
      LJ = (LOT-1)*JUMP+1
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 K=2,NS2
         KC = NP2-K
         M1 = 0
         DO 201 M=1,LJ,JUMP
         M1 = M1 + 1
         WORK(M1,K)  = X(M,K)+X(M,KC)
         WORK(M1,KC) = X(M,K)-X(M,KC)
 201     CONTINUE
  101 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) GO TO 301
         M1 = 0
         DO 202 M=1,LJ,JUMP
         M1 = M1 + 1
         WORK(M1,NS2+1) = X(M,NS2+1)+X(M,NS2+1)
 202     CONTINUE
 301     DO 102 K=2,NS2
         KC = NP2-K
         M1 = 0
         DO 302 M=1,LJ,JUMP
         M1 = M1 + 1
         X(M,K)  = WSAVE(K-1)*WORK(M1,KC)+WSAVE(KC-1)*WORK(M1,K)
         X(M,KC) = WSAVE(K-1)*WORK(M1,K) -WSAVE(KC-1)*WORK(M1,KC)
 302     CONTINUE
  102 CONTINUE
      IF (MODN .NE. 0) GO TO 303
      M1 = 0
      DO 304 M=1,LJ,JUMP
         M1 = M1 + 1
         X(M,NS2+1) = WSAVE(NS2)*WORK(M1,NS2+1)
 304  CONTINUE
 303  CONTINUE
      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1
      LNSV = N + INT(LOG(REAL(N))) + 4
      LNWK = LOT*N
C
      CALL RFFTMF(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('MCSQF1',-5)
        GO TO 400
      ENDIF
C
      DO 103 I=3,N,2
         DO 203 M=1,LJ,JUMP
            XIM1 = .5*(X(M,I-1)+X(M,I))
            X(M,I) = .5*(X(M,I-1)-X(M,I))
            X(M,I-1) = XIM1
 203     CONTINUE
  103 CONTINUE
  400 CONTINUE
      RETURN
      END


!Copyright (c) 2012-2022, Xcompact3d
!This file is part of Xcompact3d (xcompact3d.com)
!SPDX-License-Identifier: BSD 3-Clause

module decomp_2d_poisson

  use decomp_2d
  use decomp_2d_fft

  use param
  use variables

  implicit none

  private        ! Make everything private unless declared public

  !  real(mytype), private, parameter :: PI = 3.14159265358979323846_mytype

#ifdef DOUBLE_PREC
  real(mytype), parameter :: epsilon = 1.e-16_mytype
#else
  real(mytype), parameter :: epsilon = 1.e-8_mytype
#endif

  ! boundary conditions
  integer, save :: bcx, bcy, bcz

  ! decomposition object for physical space
  TYPE(DECOMP_INFO), save :: ph

  ! decomposition object for spectral space
  TYPE(DECOMP_INFO), save :: sp

  ! store sine/cosine factors
  real(mytype), save, allocatable, dimension(:) :: az,bz
  real(mytype), save, allocatable, dimension(:) :: ay,by
  real(mytype), save, allocatable, dimension(:) :: ax,bx

  ! wave numbers
  complex(mytype), save, allocatable, dimension(:,:,:) :: kxyz
  !wave numbers for stretching in a pentadiagonal matrice
  complex(mytype), save, allocatable, dimension(:,:,:,:) :: a,a2,a3
  ! work arrays,
  ! naming convention: cw (complex); rw (real);
  !                    1 = X-pencil; 2 = Y-pencil; 3 = Z-pencil
  real(mytype), allocatable, dimension(:,:,:) :: rw1,rw1b,rw2,rw2b,rw3
  complex(mytype), allocatable, dimension(:,:,:) :: cw1,cw1b,cw2,cw22,cw2b,cw2c

  ! underlying FFT library only needs to be initialised once
  logical, save :: fft_initialised = .false.

  ABSTRACT INTERFACE
     SUBROUTINE poisson_xxx(rhs)
       use decomp_2d, only : mytype
       real(mytype), dimension(:,:,:), intent(INOUT) :: rhs
     END SUBROUTINE poisson_xxx
  END INTERFACE
  PROCEDURE (poisson_xxx), POINTER :: poisson

  public :: decomp_2d_poisson_init,decomp_2d_poisson_finalize,poisson
contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Initialise Poisson solver for given boundary conditions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_poisson_init()

    implicit none

    integer :: nx, ny, nz, i

    if (nclx) then
       bcx=0
    else
       bcx=1
    endif
    if (ncly) then
       bcy=0
    else
       bcy=1
    endif
    if (nclz) then
       bcz=0
    else
       bcz=1
    endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Top level wrapper
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if (bcx==0 .and. bcy==0 .and. bcz==0) then
       poisson => poisson_000
    else if (bcx==1 .and. bcy==0 .and. bcz==0) then
       poisson => poisson_100
    else
       stop 'boundary condition not supported'
    end if

    nx = nx_global
    ny = ny_global
    nz = nz_global

    ! pressure-grid having 1 fewer point for non-periodic directions
    if (bcx==1) nx=nx-1
    if (bcy==1) ny=ny-1
    if (bcz==1) nz=nz-1

#ifdef DEBG
    if (nrank .eq. 0) print *,'# decomp_2d_poisson_init start'
#endif

    allocate(ax(nx),bx(nx))
    allocate(ay(ny),by(ny))
    allocate(az(nz),bz(nz))
    call abxyz(ax,ay,az,bx,by,bz,nx,ny,nz,bcx,bcy,bcz)

#ifdef DEBG
    if (nrank .eq. 0) print *,'# decomp_2d_poisson_init decomp_info_init'
#endif

    call decomp_info_init(nx, ny, nz, ph)
    call decomp_info_init(nx, ny, nz/2+1, sp)

#ifdef DEBG
    if (nrank .eq. 0) print *,'# decomp_2d_poisson_init decomp_info_init ok'
#endif

    ! allocate work space
    if (bcx==0 .and. bcy==0 .and. bcz==0) then
       allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(kxyz(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a2(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5))
    else if (bcx==1 .and. bcy==0 .and. bcz==0) then
       allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(cw1b(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(rw1(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), &
            ph%xst(3):ph%xen(3)))
       allocate(rw1b(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), &
            ph%xst(3):ph%xen(3)))
       allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), &
            ph%yst(3):ph%yen(3)))
       allocate(kxyz(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a2(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5))
    else if (bcx==0 .and. bcy==1 .and. bcz==0) then
       allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), &
            ph%yst(3):ph%yen(3)))
       allocate(rw2b(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), &
            ph%yst(3):ph%yen(3)))
       allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(cw2(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw22(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw2b(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw2c(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(kxyz(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a2(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a3(sp%yst(1):sp%yen(1),ny,sp%yst(3):sp%yen(3),5))
    else if (bcx==1 .and. bcy==1) then
       allocate(cw1(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(cw1b(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(cw2(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw22(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw2b(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(cw2c(sp%yst(1):sp%yen(1),sp%yst(2):sp%yen(2), &
            sp%yst(3):sp%yen(3)))
       allocate(rw1(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), &
            ph%xst(3):ph%xen(3)))
       allocate(rw1b(ph%xst(1):ph%xen(1),ph%xst(2):ph%xen(2), &
            ph%xst(3):ph%xen(3)))
       allocate(rw2(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), &
            ph%yst(3):ph%yen(3)))
       allocate(rw2b(ph%yst(1):ph%yen(1),ph%yst(2):ph%yen(2), &
            ph%yst(3):ph%yen(3)))
       if (bcz==1) then
          allocate(rw3(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
       end if
       allocate(kxyz(sp%xst(1):sp%xen(1),sp%xst(2):sp%xen(2), &
            sp%xst(3):sp%xen(3)))
       allocate(a(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a2(sp%yst(1):sp%yen(1),ny/2,sp%yst(3):sp%yen(3),5))
       allocate(a3(sp%yst(1):sp%yen(1),nym,sp%yst(3):sp%yen(3),5))
    end if

#ifdef DEBG
    if (nrank .eq. 0) print *,'# decomp_2d_poisson_init before waves'
#endif

    call waves()

#ifdef DEBG
    if (nrank .eq. 0) print *,'# decomp_2d_poisson_init end'
#endif

    return
  end subroutine decomp_2d_poisson_init

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Release memory used by Poisson solver
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_poisson_finalize

    implicit none

    deallocate(ax,bx,ay,by,az,bz)

    call decomp_info_finalize(ph)
    call decomp_info_finalize(sp)

    call decomp_2d_fft_finalize
    fft_initialised = .false.

    deallocate(kxyz)

    if (bcx==0 .and. bcy==0 .and. bcz==0) then
       deallocate(cw1)
       deallocate(a,a2,a3)
    else if (bcx==1 .and. bcy==0 .and. bcz==0) then
       deallocate(cw1,cw1b,rw1,rw1b,rw2)
       deallocate(a,a2,a3)
    else if (bcx==0 .and. bcy==1 .and. bcz==0) then
       deallocate(cw1,cw2,cw2b,rw2,rw2b)
       deallocate(a,a2,a3)
    else if (bcx==1 .and. bcy==1) then
       deallocate(cw1,cw1b,cw2,cw2b,rw1,rw1b,rw2,rw2b)
       deallocate(a,a2,a3)
       if (bcz==1) then
          deallocate(rw3)
       end if
    end if

    return
  end subroutine decomp_2d_poisson_finalize

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Solving 3D Poisson equation with periodic B.C in all 3 dimensions
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine poisson_000(rhs)

    use derivX
    use derivY
    use derivZ

    ! right-hand-side of Poisson as input
    ! solution of Poisson as output
    real(mytype), dimension(:,:,:), intent(INOUT) :: rhs

    integer, dimension(3) :: fft_start, fft_end, fft_size

    complex(mytype) :: xyzk

    complex(mytype) :: ytt,xtt,ztt,yt1,xt1,yt2,xt2
    complex(mytype) :: xtt1,ytt1,ztt1,zt1,zt2

    real(mytype) :: tmp1, tmp2,x ,y, z

    integer :: nx,ny,nz, i,j,k

    nx = nx_global
    ny = ny_global
    nz = nz_global

    if (.not. fft_initialised) then
       call decomp_2d_fft_init(PHYSICAL_IN_Z)
       fft_initialised = .true.
    end if

    ! compute r2c transform
    call decomp_2d_fft_3d(rhs,cw1)

    ! normalisation
    cw1 = cw1 / real(nx, kind=mytype) /real(ny, kind=mytype) &
         / real(nz, kind=mytype)

    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)

             ! post-processing in spectral space

             ! POST PROCESSING IN Z
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bz(k)+tmp2*az(k), &
                  tmp2*bz(k)-tmp1*az(k), kind=mytype)

             ! POST PROCESSING IN Y
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*by(j)+tmp2*ay(j), &
                  tmp2*by(j)-tmp1*ay(j), kind=mytype)
             if (j.gt.(ny/2+1)) cw1(i,j,k)=-cw1(i,j,k)

             ! POST PROCESSING IN X
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bx(i)+tmp2*ax(i), &
                  tmp2*bx(i)-tmp1*ax(i), kind=mytype)
             if (i.gt.(nx/2+1)) cw1(i,j,k)=-cw1(i,j,k)

             ! Solve Poisson
             tmp1=real(kxyz(i,j,k), kind=mytype)
             tmp2=aimag(kxyz(i,j,k))
             ! CANNOT DO A DIVISION BY ZERO
             if ((tmp1.lt.epsilon).or.(tmp2.lt.epsilon)) then
                cw1(i,j,k)=0._mytype
                !                print *,'DIV 0',i,j,k,epsilon
             else
                cw1(i,j,k)=cmplx( real(cw1(i,j,k), kind=mytype) / (-tmp1), &
                     aimag(cw1(i,j,k))/(-tmp2), kind=mytype)
             end if

             !Print result in spectal space after Poisson
             !     if (abs(out(i,j,k)) > 1.0e-4) then
             !        write(*,*) 'AFTER',i,j,k,out(i,j,k),xyzk
             !     end if

             ! post-processing backward

             ! POST PROCESSING IN Z
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bz(k)-tmp2*az(k), &
                  -tmp2*bz(k)-tmp1*az(k), kind=mytype)

             ! POST PROCESSING IN Y
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*by(j)+tmp2*ay(j), &
                  tmp2*by(j)-tmp1*ay(j), kind=mytype)
             if (j.gt.(ny/2+1)) cw1(i,j,k)=-cw1(i,j,k)

             ! POST PROCESSING IN X
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bx(i)+tmp2*ax(i), &
                  -tmp2*bx(i)+tmp1*ax(i), kind=mytype)
             if (i.gt.(nx/2+1)) cw1(i,j,k)=-cw1(i,j,k)

          end do
       end do
    end do

    ! compute c2r transform
    call decomp_2d_fft_3d(cw1,rhs)

    !   call decomp_2d_fft_finalize

    return
  end subroutine poisson_000

  subroutine poisson_100(rhs)

    implicit none

    real(mytype), dimension(:,:,:), intent(INOUT) :: rhs

    complex(mytype) :: xyzk
    real(mytype) :: tmp1, tmp2, tmp3, tmp4
    real(mytype) :: xx1,xx2,xx3,xx4,xx5,xx6,xx7,xx8

    integer :: nx,ny,nz, i,j,k, itmp

100 format(1x,a8,3I4,2F12.6)

    nx = nx_global - 1
    ny = ny_global
    nz = nz_global

    ! rhs is in Z-pencil but requires global operations in X
    call transpose_z_to_y(rhs,rw2,ph)
    call transpose_y_to_x(rw2,rw1,ph)
    do k=ph%xst(3),ph%xen(3)
       do j=ph%xst(2),ph%xen(2)
          do i=1,nx/2
             rw1b(i,j,k)=rw1(2*(i-1)+1,j,k)
          enddo
          do i=nx/2+1,nx
             rw1b(i,j,k)=rw1(2*nx-2*i+2,j,k)
          enddo
       enddo
    end do

    call transpose_x_to_y(rw1b,rw2,ph)
    call transpose_y_to_z(rw2,rhs,ph)

    if (.not. fft_initialised) then
       call decomp_2d_fft_init(PHYSICAL_IN_Z,nx,ny,nz)
       fft_initialised = .true.
    end if

    ! compute r2c transform
    call decomp_2d_fft_3d(rhs,cw1)

    ! normalisation
    cw1 = cw1 / real(nx, kind=mytype) /real(ny, kind=mytype) &
         / real(nz, kind=mytype)
#ifdef DEBUG
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             if (abs(cw1(i,j,k)) > 1.0e-4) then
                write(*,100) 'START',i,j,k,cw1(i,j,k)
             end if
          end do
       end do
    end do
#endif

    ! post-processing in spectral space

    ! POST PROCESSING IN Z
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bz(k)+tmp2*az(k), &
                  tmp2*bz(k)-tmp1*az(k), kind=mytype)
#ifdef DEBUG
             if (abs(cw1(i,j,k)) > 1.0e-4) &
                  write(*,100) 'after z',i,j,k,cw1(i,j,k)
#endif
          end do
       end do
    end do

    ! POST PROCESSING IN Y
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*by(j)+tmp2*ay(j), &
                  tmp2*by(j)-tmp1*ay(j), kind=mytype)
             if (j.gt.(ny/2+1)) cw1(i,j,k)=-cw1(i,j,k)
#ifdef DEBUG
             if (abs(cw1(i,j,k)) > 1.0e-4) &
                  write(*,100) 'after y',i,j,k,cw1(i,j,k)
#endif
          end do
       end do
    end do

    ! POST PROCESSING IN X
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          cw1b(1,j,k)=cw1(1,j,k)
          do i = 2,nx
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             tmp3 = real(cw1(nx-i+2,j,k), kind=mytype)
             tmp4 = aimag(cw1(nx-i+2,j,k))
             xx1=tmp1*bx(i)/2._mytype
             xx2=tmp1*ax(i)/2._mytype
             xx3=tmp2*bx(i)/2._mytype
             xx4=tmp2*ax(i)/2._mytype
             xx5=tmp3*bx(i)/2._mytype
             xx6=tmp3*ax(i)/2._mytype
             xx7=tmp4*bx(i)/2._mytype
             xx8=tmp4*ax(i)/2._mytype
             cw1b(i,j,k) = cmplx(xx1+xx4+xx5-xx8,-xx2+xx3+xx6+xx7, &
                  kind=mytype)
          end do
       end do
    end do
#ifdef DEBUG
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             if (abs(cw1b(i,j,k)) > 1.0e-4) then
                write(*,100) 'after x',i,j,k,cw1b(i,j,k)
             end if
          end do
       end do
    end do
#endif

    ! Solve Poisson
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             !tmp1=real(zk2(k)+yk2(j)+xk2(i), kind=mytype)
             !tmp2=aimag(zk2(k)+yk2(j)+xk2(i))
             tmp1=real(kxyz(i,j,k), kind=mytype)
             tmp2=aimag(kxyz(i,j,k))
             !xyzk=cmplx(tmp1,tmp2, kind=mytype)
             ! CANNOT DO A DIVISION BY ZERO
             if ((abs(tmp1).lt.epsilon).and.(abs(tmp2).lt.epsilon)) then
                cw1b(i,j,k)=cmplx(0._mytype,0._mytype, kind=mytype)
             end if
             if ((abs(tmp1).lt.epsilon).and.(abs(tmp2).ge.epsilon)) then
                cw1b(i,j,k)=cmplx(0._mytype, &
                     aimag(cw1b(i,j,k))/(-tmp2), kind=mytype)
             end if
             if ((abs(tmp1).ge.epsilon).and.(abs(tmp2).lt.epsilon)) then
                cw1b(i,j,k)=cmplx( real(cw1b(i,j,k), kind=mytype) &
                     /(-tmp1), 0._mytype, kind=mytype)
             end if
             if ((abs(tmp1).ge.epsilon).and.(abs(tmp2).ge.epsilon)) then
                cw1b(i,j,k)=cmplx( real(cw1b(i,j,k), kind=mytype) &
                     /(-tmp1), &
                     aimag(cw1b(i,j,k))/(-tmp2), kind=mytype)
             end if
#ifdef DEBUG
             if (abs(cw1b(i,j,k)) > 1.0e-4) &
                  write(*,100) 'AFTER',i,j,k,cw1b(i,j,k)
#endif
          end do
       end do
    end do

    ! post-processing backward

    ! POST PROCESSING IN X
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          cw1(1,j,k)=cw1b(1,j,k)
          do i = 2,nx
             tmp1 = real(cw1b(i,j,k), kind=mytype)
             tmp2 = aimag(cw1b(i,j,k))
             tmp3 = real(cw1b(nx-i+2,j,k), kind=mytype)
             tmp4 = aimag(cw1b(nx-i+2,j,k))
             xx1=tmp1*bx(i)
             xx2=tmp1*ax(i)
             xx3=tmp2*bx(i)
             xx4=tmp2*ax(i)
             xx5=tmp3*bx(i)
             xx6=tmp3*ax(i)
             xx7=tmp4*bx(i)
             xx8=tmp4*ax(i)
             cw1(i,j,k) = cmplx(xx1-xx4+xx6+xx7,-(-xx2-xx3+xx5-xx8), &
                  kind=mytype)
          end do
       end do
    end do
#ifdef DEBUG
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             if (abs(cw1(i,j,k)) > 1.0e-4) then
                write(*,100) 'AFTER X',i,j,k,cw1(i,j,k)
             end if
          end do
       end do
    end do
#endif

    ! POST PROCESSING IN Y
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*by(j)-tmp2*ay(j), &
                  tmp2*by(j)+tmp1*ay(j), kind=mytype)
             if (j.gt.(ny/2+1)) cw1(i,j,k)=-cw1(i,j,k)
#ifdef DEBUG
             if (abs(cw1(i,j,k)) > 1.0e-4) &
                  write(*,100) 'AFTER Y',i,j,k,cw1(i,j,k)
#endif
          end do
       end do
    end do

    ! POST PROCESSING IN Z
    do k = sp%xst(3),sp%xen(3)
       do j = sp%xst(2),sp%xen(2)
          do i = sp%xst(1),sp%xen(1)
             tmp1 = real(cw1(i,j,k), kind=mytype)
             tmp2 = aimag(cw1(i,j,k))
             cw1(i,j,k) = cmplx(tmp1*bz(k)-tmp2*az(k), &
                  tmp2*bz(k)+tmp1*az(k), kind=mytype)
#ifdef DEBUG
             if (abs(cw1(i,j,k)) > 1.0e-4) &
                  write(*,100) 'END',i,j,k,cw1(i,j,k)
#endif
          end do
       end do
    end do

    ! compute c2r transform
    call decomp_2d_fft_3d(cw1,rhs)

    ! rhs is in Z-pencil but requires global operations in X
    call transpose_z_to_y(rhs,rw2,ph)
    call transpose_y_to_x(rw2,rw1,ph)
    do k=ph%xst(3),ph%xen(3)
       do j=ph%xst(2),ph%xen(2)
          do i=1,nx/2
             rw1b(2*i-1,j,k)=rw1(i,j,k)
          enddo
          do i=1,nx/2
             rw1b(2*i,j,k)=rw1(nx-i+1,j,k)
          enddo
       enddo
    end do
    call transpose_x_to_y(rw1b,rw2,ph)
    call transpose_y_to_z(rw2,rhs,ph)

    !  call decomp_2d_fft_finalize

    return
  end subroutine poisson_100

  subroutine abxyz(ax,ay,az,bx,by,bz,nx,ny,nz,bcx,bcy,bcz)

    use param

    implicit none

    integer, intent(IN) :: nx,ny,nz
    integer, intent(IN) :: bcx,bcy,bcz
    real(mytype), dimension(:), intent(OUT) :: ax,bx
    real(mytype), dimension(:), intent(OUT) :: ay,by
    real(mytype), dimension(:), intent(OUT) :: az,bz

    integer :: i,j,k

    if (bcx==0) then
       do i=1,nx
          ax(i) = sin(real(i-1, kind=mytype)*PI/real(nx, kind=mytype))
          bx(i) = cos(real(i-1, kind=mytype)*PI/real(nx, kind=mytype))
       end do
    else if (bcx==1) then
       do i=1,nx
          ax(i) = sin(real(i-1, kind=mytype)*PI/2.0_mytype/ &
               real(nx, kind=mytype))
          bx(i) = cos(real(i-1, kind=mytype)*PI/2.0_mytype/ &
               real(nx, kind=mytype))
       end do
    end if

    if (bcy==0) then
       do j=1,ny
          ay(j) = sin(real(j-1, kind=mytype)*PI/real(ny, kind=mytype))
          by(j) = cos(real(j-1, kind=mytype)*PI/real(ny, kind=mytype))
       end do
    else if (bcy==1) then
       do j=1,ny
          ay(j) = sin(real(j-1, kind=mytype)*PI/2.0_mytype/ &
               real(ny, kind=mytype))
          by(j) = cos(real(j-1, kind=mytype)*PI/2.0_mytype/ &
               real(ny, kind=mytype))
       end do
    end if

    if (bcz==0) then
       do k=1,nz
          az(k) = sin(real(k-1, kind=mytype)*PI/real(nz, kind=mytype))
          bz(k) = cos(real(k-1, kind=mytype)*PI/real(nz, kind=mytype))
       end do
    else if (bcz==1) then
       do k=1,nz
          az(k) = sin(real(k-1, kind=mytype)*PI/2.0_mytype/ &
               real(nz, kind=mytype))
          bz(k) = cos(real(k-1, kind=mytype)*PI/2.0_mytype/ &
               real(nz, kind=mytype))
       end do
    end if

    return
  end subroutine abxyz

  ! ***********************************************************
  !
  subroutine waves ()
    !
    !***********************************************************

    USE derivX
    USE derivY
    USE derivZ
    USE param
    USE decomp_2d
    USE variables
    use decomp_2d_fft

    implicit none

    integer :: i,j,k
    real(mytype) :: w,wp,w1,w1p
    complex(mytype) :: xyzk
    complex(mytype) :: ytt,xtt,ztt,yt1,xt1,yt2,xt2
    complex(mytype) :: xtt1,ytt1,ztt1,zt1,zt2,tmp1,tmp2,tmp3
    complex(mytype) :: tmp4,tmp5,tmp6

    xkx(:)=0. ; xk2(:)=0. ; yky(:)=0. ; yk2(:)=0.
    zkz(:)=0. ; zk2(:)=0.

    !WAVE NUMBER IN X
    if (bcx==0) then
       do i=1,nx/2+1
          w=2.*pi*(i-1)/nx
          wp=acix6*2.*dx*sin(w/2.)+(bcix6*2.*dx)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaix6*cos(w))
          xkx(i)=cmplx(nx*wp/xlx,nx*wp/xlx, kind=mytype)
          exs(i)=cmplx(nx*w/xlx,nx*w/xlx, kind=mytype)
          xk2(i)=cmplx((nx*wp/xlx)**2,(nx*wp/xlx)**2, kind=mytype)
       enddo
       do i=nx/2+2,nx
          xkx(i)=xkx(nx-i+2)
          exs(i)=exs(nx-i+2)
          xk2(i)=xk2(nx-i+2)
       enddo
    else
       do i=1,nx
          w=2.*pi*0.5*(i-1)/nxm
          wp=acix6*2.*dx*sin(w/2.)+(bcix6*2.*dx)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaix6*cos(w))
          xkx(i)=cmplx(nxm*wp/xlx,nxm*wp/xlx, kind=mytype)
          exs(i)=cmplx(nxm*w/xlx,nxm*w/xlx, kind=mytype)
          xk2(i)=cmplx((nxm*wp/xlx)**2,(nxm*wp/xlx)**2, kind=mytype)
       enddo
       xkx(1)=0.
       exs(1)=0.
       xk2(1)=0.
    endif

    !WAVE NUMBER IN Y
    if (bcy==0) then
       do j=1,ny/2+1
          w=2.*pi*(j-1)/ny
          wp=aciy6*2.*dy*sin(w/2.)+(bciy6*2.*dy)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaiy6*cos(w))
          if (istret==0) yky(j)=cmplx(ny*wp/yly,ny*wp/yly, kind=mytype)
          if (istret.ne.0) yky(j)=cmplx(ny*wp,ny*wp, kind=mytype)
          eys(j)=cmplx(ny*w/yly,ny*w/yly, kind=mytype)
          yk2(j)=cmplx((ny*wp/yly)**2,(ny*wp/yly)**2, kind=mytype)
       enddo
       do j=ny/2+2,ny
          yky(j)=yky(ny-j+2)
          eys(j)=eys(ny-j+2)
          yk2(j)=yk2(ny-j+2)
       enddo
    else
       do j=1,ny
          w=2.*pi*0.5*(j-1)/nym
          wp=aciy6*2.*dy*sin(w/2.)+(bciy6*2.*dy)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaiy6*cos(w))
          if (istret==0) yky(j)=cmplx(nym*wp/yly,nym*wp/yly, kind=mytype)
          if (istret.ne.0) yky(j)=cmplx(nym*wp,nym*wp, kind=mytype)
          eys(j)=cmplx(nym*w/yly,nym*w/yly, kind=mytype)
          yk2(j)=cmplx((nym*wp/yly)**2,(nym*wp/yly)**2, kind=mytype)
       enddo
       yky(1)=0.
       eys(1)=0.
       yk2(1)=0.
    endif

    !WAVE NUMBER IN Z
    if (bcz==0) then
       do k=1,nz/2+1
          w=2.*pi*(k-1)/nz
          wp=aciz6*2.*dz*sin(w/2.)+(bciz6*2.*dz)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaiz6*cos(w))
          zkz(k)=cmplx(nz*wp/zlz,nz*wp/zlz, kind=mytype)
          ezs(k)=cmplx(nz*w/zlz,nz*w/zlz, kind=mytype)
          zk2(k)=cmplx((nz*wp/zlz)**2,(nz*wp/zlz)**2, kind=mytype)
       enddo
    else
       do k=1,nz/2+1
          w=2.*pi*0.5*(k-1)/nzm
          w1=2.*pi*0.5*(nzm-k+1)/nzm
          wp=aciz6*2.*dz*sin(w/2.)+(bciz6*2.*dz)*sin(3./2.*w)
          wp=wp/(1.+2.*alcaiz6*cos(w))
          w1p=aciz6*2.*dz*sin(w1/2.)+(bciz6*2.*dz)*sin(3./2.*w1)
          w1p=w1p/(1.+2.*alcaiz6*cos(w1))
          zkz(k)=cmplx(nzm*wp/zlz,-nzm*w1p/zlz, kind=mytype)
          ezs(k)=cmplx(nzm*w/zlz,nzm*w1/zlz, kind=mytype)
          zk2(k)=cmplx((nzm*wp/zlz)**2,(nzm*w1p/zlz)**2, kind=mytype)
       enddo
    endif
    !
    !if (nrank==0) then
    !   do i=1,nx
    !      print *,i,ezs(i)
    !   enddo
    !endif
    !stop

    if ((bcx==0).and.(bcz==0).and.bcy.ne.0) then
       do k = sp%yst(3), sp%yen(3)
          do j = sp%yst(2), sp%yen(2)
             do i = sp%yst(1), sp%yen(1)
                xtt=cmplx((bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                     cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                     dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)),&
                     (bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                     cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                     dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)), kind=mytype)
                ytt=cmplx((biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                     ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                     diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)),&
                     (biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                     ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                     diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)), kind=mytype)
                ztt=cmplx((biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
                     ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
                     diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)),&
                     (biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
                     ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
                     diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)), kind=mytype)
                xtt1=cmplx((aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)),&
                     (aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)), kind=mytype)
                ytt1=cmplx((aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)),&
                     (aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)), kind=mytype)
                ztt1=cmplx((aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)),&
                     (aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)), kind=mytype)
                xt1=cmplx((1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)),&
                     (1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)), kind=mytype)
                yt1=cmplx((1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)),&
                     (1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)), kind=mytype)
                zt1=cmplx((1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)),&
                     (1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)), kind=mytype)
                xt2=xk2(i)*((((ytt1+ytt)/yt1)*((ztt1+ztt)/zt1))**2)
                yt2=yk2(j)*((((xtt1+xtt)/xt1)*((ztt1+ztt)/zt1))**2)
                zt2=zk2(k)*((((xtt1+xtt)/xt1)*((ytt1+ytt)/yt1))**2)
                xyzk=xt2+yt2+zt2
                kxyz(i,j,k)=xyzk
                !   print *,i,j,k, kxyz(i,j,k)
             enddo
          enddo
       enddo
    else
       if (bcz==0) then
          do k = sp%xst(3),sp%xen(3)
             do j = sp%xst(2),sp%xen(2)
                do i = sp%xst(1),sp%xen(1)
                   xtt=cmplx((bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                        cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                        dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)),&
                        (bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                        cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                        dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)), kind=mytype)
                   ytt=cmplx((biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                        ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                        diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)),&
                        (biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                        ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                        diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)), kind=mytype)
                   ztt=cmplx((biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
                        ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
                        diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)),&
                        (biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
                        ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
                        diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)), kind=mytype)
                   xtt1=cmplx((aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)),&
                        (aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)), kind=mytype)
                   ytt1=cmplx((aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)),&
                        (aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)), kind=mytype)
                   ztt1=cmplx((aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)),&
                        (aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)), kind=mytype)
                   xt1=cmplx((1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)),&
                        (1.+2.*ailcaix6*cos(real(exs(i))*dx)), kind=mytype)
                   yt1=cmplx((1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)),&
                        (1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)), kind=mytype)
                   zt1=cmplx((1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)),&
                        (1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)), kind=mytype)
                   xt2=xk2(i)*((((ytt1+ytt)/yt1)*((ztt1+ztt)/zt1))**2)
                   yt2=yk2(j)*((((xtt1+xtt)/xt1)*((ztt1+ztt)/zt1))**2)
                   zt2=zk2(k)*((((xtt1+xtt)/xt1)*((ytt1+ytt)/yt1))**2)
                   xyzk=xt2+yt2+zt2
                   kxyz(i,j,k)=xyzk
                   !   print *,i,j,k, kxyz(i,j,k)
                enddo
             enddo
          enddo
       else
          do k = sp%xst(3),sp%xen(3)
             do j = sp%xst(2),sp%xen(2)
                do i = sp%xst(1),sp%xen(1)
                   xtt=cmplx((bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                        cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                        dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)),&
                        (bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
                        cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
                        dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)), kind=mytype)
                   ytt=cmplx((biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                        ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                        diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)),&
                        (biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
                        ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
                        diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)), kind=mytype)
                   !
                   ztt=cmplx((biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
                        ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
                        diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)),&
                        (biciz6*2.*cos(aimag(ezs(k))*3.*dz/2.)+&
                        ciciz6*2.*cos(aimag(ezs(k))*5.*dz/2.)+&
                        diciz6*2.*cos(aimag(ezs(k))*7.*dz/2.)), kind=mytype)
                   !
                   xtt1=cmplx((aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)),&
                        (aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)), kind=mytype)
                   ytt1=cmplx((aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)),&
                        (aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)), kind=mytype)
                   !
                   ztt1=cmplx((aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)),&
                        (aiciz6*2.*cos(aimag(ezs(k))*dz/2.)), kind=mytype)
                   !
                   xt1=cmplx((1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)),&
                        (1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)), kind=mytype)
                   yt1=cmplx((1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)),&
                        (1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)), kind=mytype)
                   zt1=cmplx((1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)),&
                        (1.+2.*ailcaiz6*cos(aimag(ezs(k))*dz)), kind=mytype)

                   tmp1=cmplx(real(ztt1+ztt, kind=mytype)/real(zt1, kind=mytype),&
                        aimag(ztt1+ztt)/aimag(zt1), kind=mytype)
                   tmp2=cmplx(real(ytt1+ytt, kind=mytype)/real(yt1, kind=mytype),&
                        real(ytt1+ytt, kind=mytype)/real(yt1, kind=mytype), kind=mytype)
                   tmp3=cmplx(real(xtt1+xtt, kind=mytype)/real(xt1, kind=mytype),&
                        real(xtt1+xtt, kind=mytype)/real(xt1, kind=mytype), kind=mytype)

                   tmp4=cmplx((real(tmp1, kind=mytype)*real(tmp2, kind=mytype))**2,(aimag(tmp1)*aimag(tmp2))**2, kind=mytype)
                   tmp5=cmplx((real(tmp1, kind=mytype)*real(tmp3, kind=mytype))**2,(aimag(tmp1)*aimag(tmp3))**2, kind=mytype)
                   tmp6=cmplx((real(tmp3, kind=mytype)*real(tmp2, kind=mytype))**2,(aimag(tmp3)*aimag(tmp2))**2, kind=mytype)

                   tmp1=cmplx(real(tmp4, kind=mytype)*real(xk2(i), kind=mytype),aimag(tmp4)*aimag(xk2(i)), kind=mytype)
                   tmp2=cmplx(real(tmp5, kind=mytype)*real(yk2(j), kind=mytype),aimag(tmp5)*aimag(yk2(j)), kind=mytype)
                   tmp3=cmplx(real(tmp6, kind=mytype)*real(zk2(k), kind=mytype),aimag(tmp6)*aimag(zk2(k)), kind=mytype)

                   xyzk=tmp1+tmp2+tmp3
                   kxyz(i,j,k)=xyzk
                   !         print *,i,j,k,zt1,yt1
                enddo
             enddo
          enddo
       endif
    endif

    !          do k=1,1!nz
    !          do j=1,ny
    !          do i=1,1!!nx
    !             print *,j,a(i,j,k,3),kxyz(i,j,k)
    !          enddo
    !          enddo
    !          enddo

  end subroutine waves

  !**************************************************************************
  !
  subroutine matrice_refinement()
    !
    !**************************************************************************

    USE decomp_2d
    USE variables
    USE param
    USE var
    USE MPI
    USE derivX
    USE derivY
    USE derivZ

    implicit none

    integer :: i,j,k

    complex(mytype),dimension(sp%yst(1):sp%yen(1)) :: transx
    complex(mytype),dimension(sp%yst(2):sp%yen(2)) :: transy
    complex(mytype),dimension(sp%yst(3):sp%yen(3)) :: transz
    real(mytype) :: xa0,xa1
    complex(mytype) :: ytt,xtt,ztt,yt1,xt1,yt2,xt2
    complex(mytype) :: xtt1,ytt1,ztt1,zt1,zt2,tmp1,tmp2,tmp3

    do i = sp%yst(1),sp%yen(1)
       xtt=cmplx((bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
            cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
            dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)),&
            (bicix6*2.*cos(real(exs(i), kind=mytype)*3.*dx/2.)+&
            cicix6*2.*cos(real(exs(i), kind=mytype)*5.*dx/2.)+&
            dicix6*2.*cos(real(exs(i), kind=mytype)*7.*dx/2.)), kind=mytype)
       xtt1=cmplx((aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)),&
            (aicix6*2.*cos(real(exs(i), kind=mytype)*dx/2.)), kind=mytype)
       xt1=cmplx((1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)),&
            (1.+2.*ailcaix6*cos(real(exs(i), kind=mytype)*dx)), kind=mytype)
       transx(i)=cmplx(real(xtt1+xtt, kind=mytype)/real(xt1, kind=mytype),&
            real(xtt1+xtt, kind=mytype)/real(xt1, kind=mytype), kind=mytype)!(xtt+xtt)/xt1
    enddo
    do j = sp%yst(2),sp%yen(2)
       ytt=cmplx((biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
            ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
            diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)),&
            (biciy6*2.*cos(real(eys(j), kind=mytype)*3.*dy/2.)+&
            ciciy6*2.*cos(real(eys(j), kind=mytype)*5.*dy/2.)+&
            diciy6*2.*cos(real(eys(j), kind=mytype)*7.*dy/2.)), kind=mytype)
       ytt1=cmplx((aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)),&
            (aiciy6*2.*cos(real(eys(j), kind=mytype)*dy/2.)), kind=mytype)
       yt1=cmplx((1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)),&
            (1.+2.*ailcaiy6*cos(real(eys(j), kind=mytype)*dy)), kind=mytype)
       transy(j)=cmplx(real(ytt1+ytt, kind=mytype)/real(yt1, kind=mytype),&
            real(ytt1+ytt, kind=mytype)/real(yt1, kind=mytype), kind=mytype)!(ytt+ytt)/yt1
    enddo
    if (bcz==0) then
       do k = sp%yst(3),sp%yen(3)
          ztt=cmplx((biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
               ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
               diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)),&
               (biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
               ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)+&
               diciz6*2.*cos(real(ezs(k), kind=mytype)*7.*dz/2.)), kind=mytype)
          ztt1=cmplx((aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)),&
               (aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)), kind=mytype)
          zt1=cmplx((1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)),&
               (1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)), kind=mytype)
          transz(k)=cmplx(real(ztt1+ztt, kind=mytype)/real(zt1, kind=mytype),&
               aimag(ztt1+ztt)/aimag(zt1), kind=mytype)!(ztt+ztt)/zt1
       enddo
    else
       do k = sp%yst(3),sp%yen(3)
          ztt=cmplx((biciz6*2.*cos(real(ezs(k), kind=mytype)*3.*dz/2.)+&
               ciciz6*2.*cos(real(ezs(k), kind=mytype)*5.*dz/2.)),&
               (biciz6*2.*cos(aimag(ezs(k))*3.*dz/2.)+&
               ciciz6*2.*cos(aimag(ezs(k))*5.*dz/2.)), kind=mytype)
          ztt1=cmplx((aiciz6*2.*cos(real(ezs(k), kind=mytype)*dz/2.)),&
               (aiciz6*2.*cos(aimag(ezs(k))*dz/2.)), kind=mytype)
          zt1=cmplx((1.+2.*ailcaiz6*cos(real(ezs(k), kind=mytype)*dz)),&
               (1.+2.*ailcaiz6*cos(aimag(ezs(k))*dz)), kind=mytype)
          transz(k)=cmplx(real(ztt1+ztt, kind=mytype)/real(zt1, kind=mytype),&
               aimag(ztt1+ztt)/aimag(zt1), kind=mytype)!(ztt+ztt)/zt1
       enddo
    endif

    if ((istret==1).or.(istret==2)) then

       xa0=alpha/pi+1./2./beta/pi
       if (istret==1) xa1=1./4./beta/pi
       if (istret==2) xa1=-1./4./beta/pi
       !
       !construction of the pentadiagonal matrice
       !
       do k=sp%yst(3),sp%yen(3)
          do j=1,ny/2
             do i=sp%yst(1),sp%yen(1)
                cw22(i,j,k)=cmplx(real(yky(2*j-1), kind=mytype)*real(transx(i), kind=mytype)*real(transz(k), kind=mytype),&
                     aimag(yky(2*j-1))*aimag(transx(i))*aimag(transz(k)), kind=mytype)
                cw2(i,j,k)=cmplx(real(yky(2*j), kind=mytype)*real(transx(i), kind=mytype)*real(transz(k), kind=mytype),&
                     aimag(yky(2*j))*aimag(transx(i))*aimag(transz(k)), kind=mytype)
             enddo
          enddo
       enddo

       !main diagonal
       do k=sp%yst(3),sp%yen(3)
          do j=2,ny/2-1
             do i=sp%yst(1),sp%yen(1)
                a(i,j,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(2*j-1), kind=mytype)*real(transy(2*j-1), kind=mytype)&
                     *real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                     -(real(zk2(k), kind=mytype)*real(transy(2*j-1), kind=mytype)*real(transy(2*j-1), kind=mytype)*&
                     real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                     -real(cw22(i,j,k), kind=mytype)*real(cw22(i,j,k), kind=mytype)*xa0*xa0-&
                     xa1*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)+real(cw22(i,j,k), kind=mytype)*&
                     real(cw22(i,j+1,k), kind=mytype)),&
                     -(aimag(xk2(i))*aimag(transy(2*j-1))*aimag(transy(2*j-1))*aimag(transz(k))*aimag(transz(k)))&
                     -(aimag(zk2(k))*aimag(transy(2*j-1))*aimag(transy(2*j-1))*aimag(transx(i))*aimag(transx(i)))&
                     -aimag(cw22(i,j,k))*aimag(cw22(i,j,k))*xa0*xa0-&
                     xa1*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j-1,k))+aimag(cw22(i,j,k))*aimag(cw22(i,j+1,k))), kind=mytype)
                a2(i,j,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(2*j), kind=mytype)*real(transy(2*j), kind=mytype)*&
                     real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                     -(real(zk2(k), kind=mytype)*real(transy(2*j), kind=mytype)*real(transy(2*j), kind=mytype)*&
                     real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                     -real(cw2(i,j,k), kind=mytype)*real(cw2(i,j,k), kind=mytype)*xa0*xa0-&
                     xa1*xa1*(real(cw2(i,j,k), kind=mytype)*real(cw2(i,j-1,k), kind=mytype)+real(cw2(i,j,k), kind=mytype)*&
                     real(cw2(i,j+1,k), kind=mytype)),&
                     -(aimag(xk2(i))*aimag(transy(2*j))*aimag(transy(2*j))*aimag(transz(k))*aimag(transz(k)))&
                     -(aimag(zk2(k))*aimag(transy(2*j))*aimag(transy(2*j))*aimag(transx(i))*aimag(transx(i)))&
                     -aimag(cw2(i,j,k))*aimag(cw2(i,j,k))*xa0*xa0-&
                     xa1*xa1*(aimag(cw2(i,j,k))*aimag(cw2(i,j-1,k))+aimag(cw2(i,j,k))*aimag(cw2(i,j+1,k))), kind=mytype)
             enddo
          enddo
          do i=sp%yst(1),sp%yen(1)
             a(i,1,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(1), kind=mytype)*real(transy(1), kind=mytype)*&
                  real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(1), kind=mytype)*real(transy(1), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw22(i,1,k), kind=mytype)*real(cw22(i,1,k), kind=mytype)*xa0*xa0-&
                  xa1*xa1*(real(cw22(i,1,k), kind=mytype)*real(cw22(i,2,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(1))*aimag(transy(1))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(1))*aimag(transy(1))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw22(i,1,k))*aimag(cw22(i,1,k))*xa0*xa0-xa1*xa1*(aimag(cw22(i,1,k))*aimag(cw22(i,2,k))), kind=mytype)
             a(i,ny/2,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(ny-2), kind=mytype)*real(transy(ny-2), kind=mytype)&
                  *real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(ny-2), kind=mytype)*real(transy(ny-2), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw22(i,ny/2,k), kind=mytype)*real(cw22(i,ny/2,k), kind=mytype)*xa0*xa0-&
                  xa1*xa1*(real(cw22(i,ny/2,k), kind=mytype)*real(cw22(i,ny/2-1,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(ny-2))*aimag(transy(ny-2))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(ny-2))*aimag(transy(ny-2))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw22(i,ny/2,k))*aimag(cw22(i,ny/2,k))*xa0*xa0-&
                  xa1*xa1*(aimag(cw22(i,ny/2,k))*aimag(cw22(i,ny/2-1,k))), kind=mytype)
             a2(i,1,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(2), kind=mytype)*real(transy(2), kind=mytype)*&
                  real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(2), kind=mytype)*real(transy(2), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw2(i,1,k), kind=mytype)*real(cw2(i,1,k), kind=mytype)*(xa0-xa1)*(xa0+xa1)-&
                  xa1*xa1*(real(cw2(i,1,k), kind=mytype)*real(cw2(i,2,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(2))*aimag(transy(2))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(2))*aimag(transy(2))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw2(i,1,k))*aimag(cw2(i,1,k))*(xa0-xa1)*(xa0+xa1)-&
                  xa1*xa1*(aimag(cw2(i,1,k))*aimag(cw2(i,2,k))), kind=mytype)
             a2(i,ny/2,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(ny-1), kind=mytype)*real(transy(ny-1), kind=mytype)*&
                  real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(ny-1), kind=mytype)*real(transy(ny-1), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw2(i,ny/2,k), kind=mytype)*real(cw2(i,ny/2,k), kind=mytype)*(xa0+xa1)*(xa0+xa1)-&
                  xa1*xa1*(real(cw2(i,ny/2,k), kind=mytype)*real(cw2(i,ny/2-1,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(ny-1))*aimag(transy(ny-1))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(ny-1))*aimag(transy(ny-1))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw2(i,ny/2,k))*aimag(cw2(i,ny/2,k))*(xa0+xa1)*(xa0+xa1)-&
                  xa1*xa1*(aimag(cw2(i,ny/2,k))*aimag(cw2(i,ny/2-1,k))), kind=mytype)
          enddo
       enddo

       !sup diag +1
       do k=sp%yst(3),sp%yen(3)
          do j=2,ny/2-1
             do i=sp%yst(1),sp%yen(1)
                a(i,j,k,4)=cmplx(xa0*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j+1,k), kind=mytype)+&
                     real(cw22(i,j+1,k), kind=mytype)*real(cw22(i,j+1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j+1,k))+aimag(cw22(i,j+1,k))*aimag(cw22(i,j+1,k))), kind=mytype)
                a2(i,j,k,4)=cmplx(xa0*xa1*(real(cw2(i,j,k), kind=mytype)*real(cw2(i,j+1,k), kind=mytype)+&
                     real(cw2(i,j+1,k), kind=mytype)*real(cw2(i,j+1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw2(i,j,k))*aimag(cw2(i,j+1,k))+aimag(cw2(i,j+1,k))*aimag(cw2(i,j+1,k))), kind=mytype)
             enddo
          enddo
          do i=sp%yst(1),sp%yen(1)
             a(i,1,k,4)=2.*cmplx((xa0*xa1*(real(cw22(i,1,k), kind=mytype)*real(cw22(i,2,k), kind=mytype)+&
                  real(cw22(i,2,k), kind=mytype)*real(cw22(i,2,k), kind=mytype))),&
                  (xa0*xa1*(aimag(cw22(i,1,k))*aimag(cw22(i,2,k))+aimag(cw22(i,2,k))*aimag(cw22(i,2,k)))), kind=mytype)
             a2(i,1,k,4)=cmplx((xa0-xa1)*xa1*(real(cw2(i,1,k), kind=mytype)*real(cw2(i,2,k), kind=mytype))&
                  +xa0*xa1*(real(cw2(i,2,k), kind=mytype)*real(cw2(i,2,k), kind=mytype)),&
                  (xa0-xa1)*xa1*(aimag(cw2(i,1,k))*aimag(cw2(i,2,k)))&
                  +xa0*xa1*(aimag(cw2(i,2,k))*aimag(cw2(i,2,k))), kind=mytype)
             a2(i,ny/2-1,k,4)=cmplx(xa0*xa1*(real(cw2(i,ny/2-1,k), kind=mytype)*real(cw2(i,ny/2,k), kind=mytype))&
                  +(xa0+xa1)*xa1*(real(cw2(i,ny/2,k), kind=mytype)*real(cw2(i,ny/2,k), kind=mytype)),&
                  xa0*xa1*(aimag(cw2(i,ny/2-1,k))*aimag(cw2(i,ny/2,k)))&
                  +(xa0+xa1)*xa1*(aimag(cw2(i,ny/2,k))*aimag(cw2(i,ny/2,k))), kind=mytype)
             a2(i,ny/2,k,4)=0.
          enddo
       enddo

       !sup diag +2
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=1,ny/2-2
                a(i,j,k,5)=cmplx(-real(cw22(i,j+1,k), kind=mytype)*real(cw22(i,j+2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw22(i,j+1,k))*aimag(cw22(i,j+2,k))*xa1*xa1, kind=mytype)
                a2(i,j,k,5)=cmplx(-real(cw2(i,j+1,k), kind=mytype)*real(cw2(i,j+2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw2(i,j+1,k))*aimag(cw2(i,j+2,k))*xa1*xa1, kind=mytype)
             enddo
             a(i,1,k,5)=cmplx(real(a(i,1,k,5), kind=mytype)*2.,aimag(a(i,1,k,5))*2., kind=mytype)
             a(i,ny/2-1,k,5)=0.
             a(i,ny/2,k,5)=0.
             a2(i,ny/2-1,k,5)=0.
             a2(i,ny/2,k,5)=0.
          enddo
       enddo

       !inf diag -1
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=2,ny/2
                a(i,j,k,2)=cmplx(xa0*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)+&
                     real(cw22(i,j-1,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j-1,k))+aimag(cw22(i,j-1,k))*aimag(cw22(i,j-1,k))), kind=mytype)
                a2(i,j,k,2)=cmplx(xa0*xa1*(real(cw2(i,j,k), kind=mytype)*real(cw2(i,j-1,k), kind=mytype)+&
                     real(cw2(i,j-1,k), kind=mytype)*real(cw2(i,j-1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw2(i,j,k))*aimag(cw2(i,j-1,k))+aimag(cw2(i,j-1,k))*aimag(cw2(i,j-1,k))), kind=mytype)
             enddo
             a(i,1,k,2)=0.
             a2(i,1,k,2)=0.
             a2(i,2,k,2)=cmplx(xa0*xa1*(real(cw2(i,2,k), kind=mytype)*real(cw2(i,1,k), kind=mytype))&
                  +(xa0+xa1)*xa1*(real(cw2(i,1,k), kind=mytype)*real(cw2(i,1,k), kind=mytype)),&
                  xa0*xa1*(aimag(cw2(i,2,k))*aimag(cw2(i,1,k)))&
                  +(xa0+xa1)*xa1*(aimag(cw2(i,1,k))*aimag(cw2(i,1,k))), kind=mytype)
             a2(i,ny/2,k,2)=cmplx((xa0+xa1)*xa1*(real(cw2(i,ny/2,k), kind=mytype)*real(cw2(i,ny/2-1,k), kind=mytype))&
                  +xa0*xa1*(real(cw2(i,ny/2-1,k), kind=mytype)*real(cw2(i,ny/2-1,k), kind=mytype)),&
                  (xa0+xa1)*xa1*(aimag(cw2(i,ny/2,k))*aimag(cw2(i,ny/2-1,k)))&
                  +xa0*xa1*(aimag(cw2(i,ny/2-1,k))*aimag(cw2(i,ny/2-1,k))), kind=mytype)
          enddo
       enddo
       !inf diag -2
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=3,ny/2
                a(i,j,k,1)=cmplx(-real(cw22(i,j-1,k), kind=mytype)*real(cw22(i,j-2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw22(i,j-1,k))*aimag(cw22(i,j-2,k))*xa1*xa1, kind=mytype)
                a2(i,j,k,1)=cmplx(-real(cw2(i,j-1,k), kind=mytype)*real(cw2(i,j-2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw2(i,j-1,k))*aimag(cw2(i,j-2,k))*xa1*xa1, kind=mytype)
             enddo
             a(i,1,k,1)=0.
             a(i,2,k,1)=0.
             a2(i,1,k,1)=0.
             a2(i,2,k,1)=0.
          enddo
       enddo
       !not to have a singular matrice
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             if ((real(xk2(i), kind=mytype)==0.).and.(real(zk2(k), kind=mytype)==0)) then
                a(i,1,k,3)=cmplx(1.,1., kind=mytype)
                a(i,1,k,4)=0.
                a(i,1,k,5)=0.
             endif
          enddo
       enddo

    else
       xa0=alpha/pi+1./2./beta/pi
       xa1=-1./4./beta/pi
       !
       !construction of the pentadiagonal matrice
       !
       do k=sp%yst(3),sp%yen(3)
          do j=1,nym
             do i=sp%yst(1),sp%yen(1)
                cw22(i,j,k)=cmplx(real(yky(j), kind=mytype)*real(transx(i), kind=mytype)*real(transz(k), kind=mytype),&
                     aimag(yky(j))*aimag(transx(i))*aimag(transz(k)), kind=mytype)
             enddo
          enddo
       enddo

       !main diagonal
       do k=sp%yst(3),sp%yen(3)
          do j=2,nym-1
             do i=sp%yst(1),sp%yen(1)
                a3(i,j,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(j), kind=mytype)*real(transy(j), kind=mytype)*&
                     real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                     -(real(zk2(k), kind=mytype)*real(transy(j), kind=mytype)*real(transy(j), kind=mytype)*&
                     real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                     -real(cw22(i,j,k), kind=mytype)*real(cw22(i,j,k), kind=mytype)*xa0*xa0-&
                     xa1*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)+real(cw22(i,j,k), kind=mytype)*&
                     real(cw22(i,j+1,k), kind=mytype)),&
                     -(aimag(xk2(i))*aimag(transy(j))*aimag(transy(j))*aimag(transz(k))*aimag(transz(k)))&
                     -(aimag(zk2(k))*aimag(transy(j))*aimag(transy(j))*aimag(transx(i))*aimag(transx(i)))&
                     -aimag(cw22(i,j,k))*aimag(cw22(i,j,k))*xa0*xa0-&
                     xa1*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j-1,k))+aimag(cw22(i,j,k))*aimag(cw22(i,j+1,k))), kind=mytype)
             enddo
          enddo
       enddo

       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             a3(i,1,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(1), kind=mytype)*real(transy(1), kind=mytype)*&
                  real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(1), kind=mytype)*real(transy(1), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw22(i,1,k), kind=mytype)*real(cw22(i,1,k), kind=mytype)*xa0*xa0-&
                  xa1*xa1*(real(cw22(i,1,k), kind=mytype)*real(cw22(i,2,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(1))*aimag(transy(1))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(1))*aimag(transy(1))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw22(i,1,k))*aimag(cw22(i,1,k))*xa0*xa0-xa1*xa1*(aimag(cw22(i,1,k))*aimag(cw22(i,2,k))), kind=mytype)
             a3(i,nym,k,3)=cmplx(-(real(xk2(i), kind=mytype)*real(transy(nym), kind=mytype)*real(transy(nym), kind=mytype)*&
                  real(transz(k), kind=mytype)*real(transz(k), kind=mytype))&
                  -(real(zk2(k), kind=mytype)*real(transy(nym), kind=mytype)*real(transy(nym), kind=mytype)*&
                  real(transx(i), kind=mytype)*real(transx(i), kind=mytype))&
                  -real(cw22(i,nym,k), kind=mytype)*real(cw22(i,nym,k), kind=mytype)*xa0*xa0-&
                  xa1*xa1*(real(cw22(i,nym,k), kind=mytype)*real(cw22(i,nym-1,k), kind=mytype)),&
                  -(aimag(xk2(i))*aimag(transy(nym))*aimag(transy(nym))*aimag(transz(k))*aimag(transz(k)))&
                  -(aimag(zk2(k))*aimag(transy(nym))*aimag(transy(nym))*aimag(transx(i))*aimag(transx(i)))&
                  -aimag(cw22(i,nym,k))*aimag(cw22(i,nym,k))*xa0*xa0-&
                  xa1*xa1*(aimag(cw22(i,nym,k))*aimag(cw22(i,nym-1,k))), kind=mytype)
          enddo
       enddo

       !sup diag +1
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=2,nym-1
                a3(i,j,k,4)=cmplx(xa0*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j+1,k), kind=mytype)+&
                     real(cw22(i,j+1,k), kind=mytype)*real(cw22(i,j+1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j+1,k))+aimag(cw22(i,j+1,k))*aimag(cw22(i,j+1,k))), kind=mytype)
             enddo
             a3(i,1,k,4)=cmplx((xa0*xa1*(real(cw22(i,1,k), kind=mytype)*real(cw22(i,2,k), kind=mytype)+&
                  real(cw22(i,2,k), kind=mytype)*real(cw22(i,2,k), kind=mytype))),&
                  (xa0*xa1*(aimag(cw22(i,1,k))*aimag(cw22(i,2,k))+aimag(cw22(i,2,k))*aimag(cw22(i,2,k)))), kind=mytype)
          enddo
       enddo
       !sup diag +2
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=1,nym-2
                a3(i,j,k,5)=cmplx(-real(cw22(i,j+1,k), kind=mytype)*real(cw22(i,j+2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw22(i,j+1,k))*aimag(cw22(i,j+2,k))*xa1*xa1, kind=mytype)
             enddo
             !a3(i,1,k,5)=a3(i,1,k,5)*2.
             !a3(i,1,k,5)=0.
             a3(i,nym-1,k,5)=0.
             a3(i,nym,k,5)=0.
          enddo
       enddo

       !inf diag -1
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=2,nym
                a3(i,j,k,2)=cmplx(xa0*xa1*(real(cw22(i,j,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)+&
                     real(cw22(i,j-1,k), kind=mytype)*real(cw22(i,j-1,k), kind=mytype)),&
                     xa0*xa1*(aimag(cw22(i,j,k))*aimag(cw22(i,j-1,k))+aimag(cw22(i,j-1,k))*aimag(cw22(i,j-1,k))), kind=mytype)
             enddo
             a3(i,1,k,2)=0.
          enddo
       enddo
       !inf diag -2
       do k=sp%yst(3),sp%yen(3)
          do i=sp%yst(1),sp%yen(1)
             do j=3,nym
                a3(i,j,k,1)=cmplx(-real(cw22(i,j-1,k), kind=mytype)*real(cw22(i,j-2,k), kind=mytype)*xa1*xa1,&
                     -aimag(cw22(i,j-1,k))*aimag(cw22(i,j-2,k))*xa1*xa1, kind=mytype)
             enddo
             a3(i,1,k,1)=0.
             a3(i,2,k,1)=0.
          enddo
       enddo

       !not to have a singular matrice
       !   do k=sp%yst(3),sp%yen(3)
       !   do i=sp%yst(1),sp%yen(1)
       !      if ((xkx(i)==0.).and.(zkz(k)==0)) then
       if (nrank==0) then
          a3(1,1,1,3)=cmplx(1.,1., kind=mytype)
          a3(1,1,1,4)=0.
          a3(1,1,1,5)=0.
       endif
       !      endif
       !   enddo
       !   enddo
    endif

    return
  end subroutine matrice_refinement

end module decomp_2d_poisson