      ! -------------------------------------------------------------
      !
      ! This file contains subroutines for imaginary time convolution of
      ! Green's functions in the DLR
      !
      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      !> Get tensor taking a set of DLR coefficients to the matrix of
      !! convolution by the corresponding Green's function
      !!
      !! To obtain the matrix C of convolution by a Green's function G,
      !! use the output of this subroutine with the subroutine
      !! dlr_convtens.
      !!
      !! @param[in]   beta    inverse temperature
      !! @param[in]   xi      xi=-1 for fermionic case; xi=1 for bosonic
      !!                        case
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   dlrrf   DLR frequency nodes
      !! @param[in]   dlrit   DLR imaginary time nodes
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[out]  phi     tensor taking DLR coefficients of g to
      !!                        matrix C of convolution by g. C takes
      !!                        DLR coefficients of a function f ->
      !!                        DLR grid values of the convolution
      !!                        g * f.

      subroutine dlr_convtens(beta,xi,r,dlrrf,dlrit,it2cf,it2cfp,phi)

      implicit none
      integer r,xi,it2cfp(r)
      real *8 beta,dlrrf(r),dlrit(r),it2cf(r,r)
      real *8 phi(r*r,r)
      real *8, external :: kfun

      integer j,k,l,ier,maxrec,numint,info
      real *8 one,rint1,rint2
      real *8, allocatable :: phitmp(:,:,:),phitmp2(:,:)
      real *8, external :: kfunf,kfunf_rel,expfun

      one = 1.0d0

      ! Get tensor taking DLR coefficients to matrix of convolution from
      ! DLR coefficients -> imaginary time grid values

      allocate(phitmp(r,r,r),phitmp2(r,r*r))

      do l=1,r
        do k=1,r
          do j=1,r

            if (k.ne.l) then

              phitmp(j,k,l) =&
                (kfunf_rel(dlrit(j),dlrrf(l))*expfun(dlrrf(k),xi) -&
                kfunf_rel(dlrit(j),dlrrf(k))*expfun(dlrrf(l),xi))/&
                (dlrrf(k)-dlrrf(l))

            else

              if (dlrit(j).gt.0.0d0) then

                phitmp(j,k,l) = (dlrit(j)*expfun(dlrrf(k),xi)+&
                  xi*kfunf(1.0d0,dlrrf(k)))*kfunf_rel(dlrit(j),dlrrf(k))

              else

                phitmp(j,k,l) = (dlrit(j)*expfun(dlrrf(k),xi)+&
                  kfunf(0.0d0,dlrrf(k)))*kfunf_rel(dlrit(j),dlrrf(k))

              endif
            endif

          enddo
        enddo
      enddo

      ! Precompose with imaginary time grid values -> DLR coefficients
      ! transformation to obtain final tensor

      do l=1,r
        do k=1,r
          do j=1,r
            phitmp2(k,(l-1)*r+j) = phitmp(j,k,l)
          enddo
        enddo
      enddo

      call dgetrs('T',r,r*r,it2cf,r,it2cfp,phitmp2,r,info)

      do l=1,r
        do k=1,r
          do j=1,r
            phitmp(j,k,l) = phitmp2(k,(l-1)*r+j)
          enddo
        enddo
      enddo

      ! Reshape

      do l=1,r
        do k=1,r
          do j=1,r
            phi((k-1)*r+j,l) = phitmp(j,k,l)
          enddo
        enddo
      enddo

      ! Scale by beta for convolutions on [0,beta]

      phi = beta*phi

      end subroutine dlr_convtens

      !> Get the matrix of convolution by a Green's function.
      !!
      !! The output of this subroutine is the matrix gmat of convolution
      !! by a Green's function G. The subroutine dlr_conv can be used to
      !! apply gmat to a vector of imaginary time grid values of a
      !! Green's function F, giving the values of G * F at the imaginary
      !! time grid points.
      !!
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   n       number of orbital indices
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[in]   phi     tensor produced by subroutine
      !!                        dlr_convtens taking DLR coefficients
      !!                        of g to matrix of convolution by g.
      !! @param[in]   g       values of Green's function at imaginary
      !!                        time grid points
      !! @param[out]  gmat    matrix of convolution by g

      subroutine dlr_convmat(r,n,it2cf,it2cfp,phi,g,gmat)

      implicit none
      integer r,n,it2cfp(r)
      real *8 phi(r*r,r),it2cf(r,r),g(r,n,n)
      real *8 gmat(r*n,r*n)

      integer i,j,info
      real *8, allocatable :: gc(:,:,:),tmp(:,:)

      allocate(gc(r,n,n),tmp(r,r*n*n))

      ! Get DLR coefficients of G_ij

      call dlr_it2cf(r,n,it2cf,it2cfp,g,gc)

      ! Get convolution matrix

      call dgemm('N','N',r*r,n*n,r,1.0d0,phi,r*r,gc,r,0.0d0,tmp,r*r)

      do j=1,n
        do i=1,n
          gmat((i-1)*r+1:i*r,(j-1)*r+1:j*r) = &
            tmp(:,((j-1)*n+(i-1))*r+1:((j-1)*n+(i-1)+1)*r)
        enddo
      enddo

      end subroutine dlr_convmat

      !> Convolve two Green's functions.
      !!
      !! This subroutine takes the matrix of convolution by a Green's
      !! function G produced by dlr_convmat, and performs the
      !! convolution between G and a Green's function F, given by its
      !! values on the imaginary time grid. It returns the values of the
      !! convolution H = G * F at the imaginary time grid points.
      !!
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   n       number of orbital indices
      !! @param[in]   gmat    matrix of convolution by G
      !! @param[in]   f       values of Green's function F at imaginary
      !!                        time grid points
      !! @param[out]  h       values of convolution H = G * F at
      !!                        imaginary time grid points

      subroutine dlr_conv(r,n,gmat,f,h)

      implicit none
      integer r,n
      real *8 gmat(r*n,r*n),f(r,n,n),h(r,n,n)

      call dgemm('N','N',r*n,n,r*n,1.0d0,gmat,r*n,f,r*n,0.0d0,h,r*n)

      end subroutine dlr_conv

      !> Initialize the fast DLR convolution subroutine dlr_fstconv
      !!
      !! The output fstconv of this subroutine should be used as a
      !! parameter in every call to the subroutine dlr_fstconv
      !!
      !! @param[in]   beta      inverse temperature
      !! @param[in]   r         number of DLR basis functions
      !! @param[in]   dlrrf     DLR frequency nodes
      !! @param[in]   dlrit     DLR imaginary time nodes
      !! @param[in]   cf2it     DLR coefficients -> imaginary time grid
      !!                          values transform matrix
      !! @param[out]  fstconv   arrays used for fast convolution

      subroutine dlr_fstconv_init(beta,r,dlrrf,dlrit,cf2it,fstconv)

      implicit none
      integer r
      real *8 beta,dlrrf(r),dlrit(r),cf2it(r,r),fstconv(r,2*r)

      integer i,j
      real *8, external :: kfunf_rel

      do j=1,r
        do i=1,r
          if (i.eq.j) then
            fstconv(i,j) = 0.0d0
          else
            fstconv(i,j) = beta/(dlrrf(j)-dlrrf(i))
          endif
        enddo
      enddo

      do j=1,r
        do i=1,r
          if (dlrit(i).gt.0.0d0) then

            fstconv(i,r+j) = beta*(dlrit(i)-kfunf_rel(1.0d0,dlrrf(j)))&
              *cf2it(i,j)

          else

            fstconv(i,r+j) = beta*(dlrit(i)+kfunf_rel(0.0d0,dlrrf(j)))&
              *cf2it(i,j)

          endif

        enddo
      enddo

      end subroutine dlr_fstconv_init

      !> Convolve two Green's functions using the fast convolution
      !! method, which carries out the convolution directly in the DLR
      !! coefficient domain
      !!
      !! This subroutine performs the convolution between Green's
      !! functions F and G, given by their values on the imaginary time
      !! grid, and returns the values of the convolution H = G * F on
      !! the imaginary time grid.
      !!
      !! @param[in]  r        number of DLR basis functions
      !! @param[in]  n        number of orbital indices
      !! @param[in]  cf2it    DLR coefficients -> imaginary time grid
      !!                        values transform matrix
      !! @param[in]  it2cf    imaginary time grid values -> DLR
      !!                        coefficients transform matrix, stored in
      !!                        LAPACK LU factored format; LU factors
      !! @param[in]  it2cfp   imaginary time grid values -> DLR
      !!                        coefficients transform matrix, stored in
      !!                        LAPACK LU factored format; LU pivots
      !! @param[in]  fstconv  arrays used for fast convolution
      !! @param[in]  f        values of Green's function F at imaginary
      !!                        time grid points
      !! @param[in]  g        values of Green's function G at imaginary
      !!                        time grid points
      !! @param[out] h        values of convolution H = F * G at
      !!                         imaginary time grid points

      subroutine dlr_fstconv(r,n,cf2it,it2cf,it2cfp,fstconv,f,g,h)

      implicit none
      integer r,n,it2cfp(r)
      real *8 it2cf(r,r),fstconv(r,2*r),cf2it(r,r)
      real *8 f(r,n,n),g(r,n,n),h(r,n,n)

      integer info,i,j,k
      real *8, allocatable :: fgc(:,:,:,:),tmp(:,:,:,:),hc(:,:,:)

      allocate(fgc(r,n,n,2),tmp(r,n,n,2),hc(r,n,n))

      ! Get DLR coefficients of f and g

      fgc(:,:,:,1) = f
      fgc(:,:,:,2) = g

      call dgetrs('N',r,n*n*2,it2cf,r,it2cfp,fgc,r,info)

      ! Off-diagonal contribution to convolution

      call dgemm('N','N',r,n*n*2,r,1.0d0,fstconv,r,fgc,r,0.0d0,tmp,r)

      ! NOTE: This code might be faster for small n
      !
      !do j=1,n
      !  do i=1,n
      !    hc(:,i,j) = 0
      !    do k=1,n
      !      hc(:,i,j) = hc(:,i,j)+fgc(:,i,k,2)*tmp(:,k,j,1) &
      !        + fgc(:,i,k,1)*tmp(:,k,j,2)
      !    enddo
      !  enddo
      !enddo

      do i=1,r
        call dgemm('N','N',n,n,n,1.0d0,fgc(i,:,:,2),n,tmp(i,:,:,1),n,0.0d0,hc(i,:,:),n)
        call dgemm('N','N',n,n,n,1.0d0,fgc(i,:,:,1),n,tmp(i,:,:,2),n,1.0d0,hc(i,:,:),n)
      enddo

      call dlr_cf2it(r,n,cf2it,hc,h)

      ! Diagonal contribution to convolution

      ! NOTE: This code might be faster for small n
      !
      !do j=1,n
      !  do i=1,n
      !    hc(:,i,j) = 0
      !    do k=1,n
      !      hc(:,i,j) = hc(:,i,j) + fgc(:,i,k,1)*fgc(:,k,j,2)
      !    enddo
      !  enddo
      !enddo

      do i=1,r
        call dgemm('N','N',n,n,n,1.0d0,fgc(i,:,:,1),n,fgc(i,:,:,2),n,0.0d0,hc(i,:,:),n)
      enddo

      call dgemm('N','N',r,n*n,r,1.0d0,fstconv(1,r+1),r,hc,r,1.0d0,h,r)

      end subroutine dlr_fstconv

      !> Get tensor taking a set of DLR coefficients to the matrix of
      !! convolution by the corresponding Green's function, acting from
      !! DLR coefficients to DLR grid values.
      !!
      !! Given the DLR coefficients of a Green's function g, applying
      !! this tensor produces a matrix A of convolution by g which takes
      !! the DLR coefficients of a function f to the DLR grid values of
      !! the convolution f * g. Since we typically want a convolution
      !! matrix operating on grid values, we typically use the subroutine
      !! dlr_convtens instead of this one. Alternatively,
      !! one can use the tensor produced by this subroutine with the
      !! subroutine dlr_convmat_vcc to produce a convolution matrix
      !! operating on grid values.
      !!
      !! @param[in]   beta    inverse temperature
      !! @param[in]   xi      xi=-1 for fermionic case; xi=1 for bosonic
      !!                        case
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   dlrrf   DLR frequency nodes
      !! @param[in]   dlrit   DLR imaginary time nodes
      !! @param[out]  phivcc  tensor taking DLR coefficients of g to
      !!                        matrix C of convolution by g. C takes
      !!                        DLR coefficients of a function f -> DLR
      !!                        grid values of the convolution g * f.
      !!                        "vcc" indicates that for the tensor
      !!                        phi_{ijk}, i indexes grid values, and
      !!                        j,k index DLR coefficients.

      subroutine dlr_convtens_vcc(beta,xi,r,dlrrf,dlrit,phivcc)

      implicit none
      integer r,xi
      real *8 beta,dlrrf(r),dlrit(r)
      real *8 phivcc(r*r,r)
      real *8, external :: kfun

      integer j,k,l,ier,maxrec,numint
      real *8 one,rint1,rint2
      real *8, external :: kfunf,kfunf_rel,expfun

      one = 1.0d0

      ! Get tensor taking DLR coefficients to matrix of convolution from
      ! DLR coefficients -> imaginary time grid values

      do l=1,r
        do k=1,r
          do j=1,r

            if (k.ne.l) then

              phivcc((k-1)*r+j,l) = &
                (kfunf_rel(dlrit(j),dlrrf(l))*expfun(dlrrf(k),xi) -&
                kfunf_rel(dlrit(j),dlrrf(k))*expfun(dlrrf(l),xi))/&
                (dlrrf(k)-dlrrf(l))

            else

              if (dlrit(j).gt.0.0d0) then

                phivcc((k-1)*r+j,l) = (dlrit(j)*expfun(dlrrf(k),xi)+&
                  xi*kfunf(1.0d0,dlrrf(k)))*kfunf_rel(dlrit(j),dlrrf(k))

              else

                phivcc((k-1)*r+j,l) = (dlrit(j)*expfun(dlrrf(k),xi)+&
                  kfunf(0.0d0,dlrrf(k)))*kfunf_rel(dlrit(j),dlrrf(k))

              endif
            endif

          enddo
        enddo
      enddo

      ! Scale by beta for convolutions on [0,beta]

      phivcc = beta*phivcc

      end subroutine dlr_convtens_vcc

      !> Get the matrix of convolution by a Green's function from the
      !! tensor produced by the subroutine dlr_convtens_vcc
      !!
      !! The output of this subroutine is the matrix gmat of convolution
      !! by G. gmat is applied to a vector of imaginary time grid
      !! values of a Green's function F, and returns the values of
      !! G * F at the imaginary time grid points.
      !!
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[in]   phivcc  tensor produced by subroutine
      !!                        dlr_convtens_vcc taking DLR coefficients
      !!                        of g to matrix of convolution by g,
      !!                        acting from DLR coefficients to DLR
      !!                        grid values.
      !! @param[in]   g       values of Green's function at imaginary
      !!                        time grid points
      !! @param[out]  gmat    matrix of convolution by g

      subroutine dlr_convmat_vcc(r,it2cf,it2cfp,phivcc,g,gmat)

      implicit none
      integer r,it2cfp(r)
      real *8 phivcc(r*r,r),it2cf(r,r),g(r)
      real *8 gmat(r,r)

      integer i,j,info
      real *8, allocatable :: gc(:)

      ! Get DLR coefficients of G

      allocate(gc(r))

      call dlr_it2cf(r,1,it2cf,it2cfp,g,gc)

      ! Get convolution matrix taking DLR coefficients -> imaginary time
      ! grid values

      call dgemv('N',r*r,r,1.0d0,phivcc,r*r,gc,1,0.0d0,&
        gmat,1)

      ! Precompose with matrix taking imaginary time grid values -> DLR
      ! coefficients

      gmat = transpose(gmat)

      call dgetrs('T',r,r,it2cf,r,it2cfp,gmat,r,info)

      gmat = transpose(gmat)

      end subroutine dlr_convmat_vcc

      !> Get weight matrix for computing L2 inner products of Green's
      !! functions:
      !!
      !! int_0^beta F(tau) * G(tau) dtau
      !!
      !! is approximated by
      !!
      !! sum_jk f(j) ipmat(j,k) g(k)
      !!
      !! with f and g the values of F and G at the DLR imaginary time
      !! nodes.
      !!
      !! @param[in]   beta    inverse temperature
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   dlrrf   DLR frequency nodes
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[out]  ipmat   weight matrix for L2 inner products of
      !!                        Green's functions

      subroutine dlr_ipmat(beta,r,dlrit,dlrrf,it2cf,it2cfp,ipmat)

      implicit none
      integer r,it2cfp(r)
      real *8 beta,dlrit(r),dlrrf(r),it2cf(r,r)
      real *8 ipmat(r,r)

      integer j,k,info
      integer, allocatable :: qit2cfp(:)
      real *16, external :: qexpm1
      real *16, allocatable :: qipmat(:,:),qdlrit(:),qdlrrf(:)
      real *16, allocatable :: qit2cf(:,:)
      real *16, external :: qkfunf_rel

      allocate(qipmat(r,r),qdlrit(r),qdlrrf(r),qit2cf(r,r),qit2cfp(r))

      qdlrit = dlrit
      qdlrrf = dlrrf

      ! Get weight matrix take DLR coefficients of two Green's functions
      ! to their inner product

      do k=1,r
        do j=1,r

          if (qdlrrf(j)+qdlrrf(k).gt.0.0q0) then
            qipmat(j,k) = qkfunf_rel(0.0q0,qdlrrf(j))&
              *qkfunf_rel(0.0q0,qdlrrf(k))*qexpm1(qdlrrf(j)+qdlrrf(k))
          else
            qipmat(j,k) = qkfunf_rel(1.0q0,qdlrrf(j))&
              *qkfunf_rel(1.0q0,qdlrrf(k))&
              *qexpm1(-(qdlrrf(j)+qdlrrf(k)))
          endif

        enddo
      enddo

      ! Get imaginary time grid values -> DLR coefficients
      ! transformation in quad

      do k=1,r
        do j=1,r
          qit2cf(j,k) = qkfunf_rel(qdlrit(j),qdlrrf(k))
        enddo
      enddo

      call qgefa(qit2cf,r,r,qit2cfp,info)

      ! Postcompose with transpose of imaginary time grid values -> DLR coefficients
      ! transformation

      do k=1,r
        call qgesl(qit2cf,r,r,qit2cfp,qipmat(:,k),1)
      enddo

      ! Precompose with imaginary time grid values -> DLR
      ! coefficients transformation to obtain final weight matrix

      qipmat = transpose(qipmat)

      do k=1,r
        call qgesl(qit2cf,r,r,qit2cfp,qipmat(:,k),1)
      enddo

      qipmat = transpose(qipmat)

      ipmat = qipmat

      ! Scale by beta for inner product on [0,beta]

      ipmat = beta*ipmat

      end subroutine dlr_ipmat

      !> Evaluate the function \f$f(\omega) = (1-\xi \cdot \exp(-\omega))/(1+\exp(-\omega))\f$,
      !! for \f$\xi = \pm 1\f$
      !!
      !! @param[in]   om      frequency \f$\omega\f$
      !! @param[in]   xi      xi=-1 for fermionic case; xi=1 for bosonic
      !!                        case
      !!
      !! @param[out]  expfun  value of the function \f$f(\omega)\f$

      function expfun(om,xi)

      ! Evaluate the function f(om) = (1-xi*exp(-om))/(1+exp(-om)), for
      ! xi = +-1

      implicit none
      real *8 expfun
      real *8, intent(in) :: om
      integer, intent(in) :: xi

      if (om.ge.0.0d0) then
        expfun = (1.0d0-xi*exp(-om))/(1.0d0+exp(-om))
      else
        expfun = (exp(om)-1.0d0*xi)/(exp(om)+1.0d0)
      endif

      end function expfun


c
c ubarsolv.f subroutine to calculate barotropic velocity on c grid
c variable depth last change 21/10/94
c adds time dependent pressure torque term to forcing in psi eqn
c error corrected 14/6/97, domain extended 9/2/1
c updated for generalised grid (RMA, 10/5/05)
c
      subroutine ubarsolv(ubloc,psiloc)
#include "ocean.cmn"

      integer i,j,k,n,m,km,im

      real ubloc(2,0:maxi+1,0:maxj)
      real psiloc(0:maxi,0:maxj)

      n = imax
      m = jmax + 1
c
c solve Psi equation
c
      do 10 i=1,n*m-1
         im=min(i+n+1,n*m)
         do 10 j=i+1,im
            gb(j)=gb(j) - ratm(j,j-i)*gb(i)
   10 continue
      gb(n*m)=gb(n*m)/gap(n*m,n+2)
      do 20 i=n*m-1,1,-1
         km=min(n+1,n*m-i)
         do 30 k=1,km
            gb(i)=gb(i) - gap(i,n+2+k)*gb(i+k)
   30    continue
         gb(i)=gb(i)/gap(i,n+2)
   20 continue
c
c write to Psi for convenience (useful if ACC)
c
      do j=0,jmax
         do i=1,imax
            k = i + j*n
            psiloc(i,j) = gb(k)
         enddo
         psiloc(0,j) = psiloc(imax,j)
      enddo
c
c calculate barotropic vely where Psi (and ub) defined
c
      do j=1,jmax
         do i=1,imax
            ubloc(1,i,j) = -rh(1,i,j)*c(j)*(psiloc(i,j) - psiloc(i,j-1))
     2                     *rds(j)
         enddo
      enddo

      do j=1,jmax-1
         do i=1,imax
            ubloc(2,i,j) = rh(2,i,j)*(psiloc(i,j) - psiloc(i-1,j))
     2                     *rcv(j)*rdphi
         enddo
      enddo

c set velocity to zero at N and S boundaries
      do i=1,imax
         ubloc(2,i,jmax) = 0.
         ubloc(2,i,0) = 0.
      enddo

c periodic b.c. for ub(2) required only for island integral

      do j=1,jmax
         ubloc(2,imax+1,j) = ubloc(2,1,j)
         ubloc(1,0,j) = ubloc(1,imax,j)
         ubloc(1,imax+1,j) = ubloc(1,1,j)
         ubloc(2,0,j) = ubloc(2,imax,j)
      enddo
      ubloc(2,imax+1,0) = ubloc(2,1,0)
      ubloc(2,0,0) = ubloc(2,imax,0)

      end


!_______________________________________________________________________
      subroutine advt2_diag(fb,f,fclim,ff,xflux,yflux)
! integrate conservative scalar equations
! this is a first-order upstream scheme, which reduces implicit
! diffusion using the Smolarkiewicz iterative upstream scheme with an
! antidiffusive velocity
! it is based on the subroutines of Gianmaria Sannino (Inter-university
! Computing Consortium, Rome, Italy) and Vincenzo Artale (Italian
! National Agency for New Technology and Environment, Rome, Italy)
      implicit none
      include 'pom.h'
      real fb(im,jm,kb),f(im,jm,kb),fclim(im,jm,kb),ff(im,jm,kb)
      real xflux(im,jm,kb),yflux(im,jm,kb)
      real fbmem(im,jm,kb),eta(im,jm)
      real xmassflux(im,jm,kb),ymassflux(im,jm,kb),zwflux(im,jm,kb)

! diag
      include 'pom_diag.h'

      integer i,j,k,itera

! diag
      do k=1,kb
        do j=1,jm
          do i=1,im
            xadvterm(i,j,k)=0.e0
            yadvterm(i,j,k)=0.e0
            wadvterm(i,j,k)=0.e0
          end do
        end do
      end do

! calculate horizontal mass fluxes
      do k=1,kb
        do j=1,jm
          do i=1,im
            xmassflux(i,j,k)=0.e0
            ymassflux(i,j,k)=0.e0
          end do
        end do
      end do

      do k=1,kbm1
        do j=2,jmm1
          do i=2,im
            xmassflux(i,j,k)=0.25e0*(dy(i-1,j)+dy(i,j))
     $                             *(dt(i-1,j)+dt(i,j))*u(i,j,k)
          end do
        end do

        do j=2,jm
          do i=2,imm1
            ymassflux(i,j,k)=0.25e0*(dx(i,j-1)+dx(i,j))
     $                             *(dt(i,j-1)+dt(i,j))*v(i,j,k)
          end do
        end do
      end do

      do j=1,jm
        do i=1,im
          fb(i,j,kb)=fb(i,j,kbm1)
          eta(i,j)=etb(i,j)
        end do
      end do

      do k=1,kb
        do j=1,jm
          do i=1,im
            zwflux(i,j,k)=w(i,j,k)
            fbmem(i,j,k)=fb(i,j,k)
          end do
        end do
      end do

!! debug
!      do k=1,kb-1
!      do j=1,jm
!      do i=1,im
!        write(97,*) 'fbmem ',my_task,i,j,k,fbmem(i,j,k)
!      end do
!      end do
!      end do
!      do k=1,kb-1
!      do j=1,jm
!      do i=1,im
!        write(98,*) 'xmassflux ',my_task,i,j,k,xmassflux(i,j,k)
!      end do
!      end do
!      end do
!      do k=1,kb-1
!      do j=1,jm
!      do i=1,im
!        write(99,*) 'ymassflux ',my_task,i,j,k,ymassflux(i,j,k)
!      end do
!      end do
!      end do
!      call mpi_finalize
!      stop

! start Smolarkiewicz scheme
      do itera=1,nitera

! upwind advection scheme
        do k=1,kbm1
          do j=2,jm
            do i=2,im
              xflux(i,j,k)=0.5e0
     $                      *((xmassflux(i,j,k)+abs(xmassflux(i,j,k)))
     $                        *fbmem(i-1,j,k)+
     $                        (xmassflux(i,j,k)-abs(xmassflux(i,j,k)))
     $                        *fbmem(i,j,k))

              yflux(i,j,k)=0.5e0
     $                      *((ymassflux(i,j,k)+abs(ymassflux(i,j,k)))
     $                        *fbmem(i,j-1,k)+
     $                        (ymassflux(i,j,k)-abs(ymassflux(i,j,k)))
     $                        *fbmem(i,j,k))
            end do
          end do
        end do

        do j=2,jmm1
          do i=2,imm1
            zflux(i,j,1)=0.e0
            if(itera.eq.1) zflux(i,j,1)=w(i,j,1)*f(i,j,1)*art(i,j)
            zflux(i,j,kb)=0.e0
          end do
        end do

        do k=2,kbm1
          do j=2,jmm1
            do i=2,imm1
              zflux(i,j,k)=0.5e0
     $                      *((zwflux(i,j,k)+abs(zwflux(i,j,k)))
     $                       *fbmem(i,j,k)+
     $                        (zwflux(i,j,k)-abs(zwflux(i,j,k)))
     $                       *fbmem(i,j,k-1))
              zflux(i,j,k)=zflux(i,j,k)*art(i,j)
            end do
          end do
        end do

! add net advective fluxes and step forward in time
        do k=1,kbm1
          do j=2,jmm1
            do i=2,imm1
              ff(i,j,k)=xflux(i+1,j,k)-xflux(i,j,k)
     $                 +yflux(i,j+1,k)-yflux(i,j,k)
     $                 +(zflux(i,j,k)-zflux(i,j,k+1))/dz(k)
              ff(i,j,k)=(fbmem(i,j,k)*(h(i,j)+eta(i,j))*art(i,j)
     $                   -dti2*ff(i,j,k))/((h(i,j)+etf(i,j))*art(i,j))
            end do
          end do
        end do
        ! next line added on 22-Jul-2009 by Raffaele Bernardello
        call exchange3d_mpi(ff(:,:,1:kbm1),im,jm,kbm1)

! diag
        do k=1,kbm1
          do j=2,jmm1
            do i=2,imm1
              xadvterm(i,j,k)=xadvterm(i,j,k)
     $                 -(xflux(i+1,j,k)-xflux(i,j,k))
     $                  /((h(i,j)+etf(i,j))*art(i,j))
              yadvterm(i,j,k)=yadvterm(i,j,k)
     $                 -(yflux(i,j+1,k)-yflux(i,j,k))
     $                  /((h(i,j)+etf(i,j))*art(i,j))
              wadvterm(i,j,k)=wadvterm(i,j,k)
     $                 -(zflux(i,j,k)-zflux(i,j,k+1))/dz(k)
     $                  /((h(i,j)+etf(i,j))*art(i,j))
            end do
          end do
        end do

! calculate antidiffusion velocity
        call smol_adif(xmassflux,ymassflux,zwflux,ff)

        do j=1,jm
          do i=1,im
            eta(i,j)=etf(i,j)
            do k=1,kb
              fbmem(i,j,k)=ff(i,j,k)
            end do
          end do
        end do

! end of Smolarkiewicz scheme
      end do

! add horizontal diffusive fluxes
      do k=1,kb
        do j=1,jm
          do i=1,im
            fb(i,j,k)=fb(i,j,k)-fclim(i,j,k)
          end do
        end do
      end do

      do k=1,kbm1
        do j=2,jm
          do i=2,im
            xmassflux(i,j,k)=0.5e0*(aam(i,j,k)+aam(i-1,j,k))
            ymassflux(i,j,k)=0.5e0*(aam(i,j,k)+aam(i,j-1,k))
          end do
        end do
      end do

      do k=1,kbm1
        do j=2,jm
          do i=2,im
           xflux(i,j,k)=-xmassflux(i,j,k)*(h(i,j)+h(i-1,j))*tprni
     $                   *(fb(i,j,k)-fb(i-1,j,k))*dum(i,j)
     $                   *(dy(i,j)+dy(i-1,j))*0.5e0/(dx(i,j)+dx(i-1,j))
           yflux(i,j,k)=-ymassflux(i,j,k)*(h(i,j)+h(i,j-1))*tprni
     $                   *(fb(i,j,k)-fb(i,j-1,k))*dvm(i,j)
     $                   *(dx(i,j)+dx(i,j-1))*0.5e0/(dy(i,j)+dy(i,j-1))
          end do
        end do
      end do

      do k=1,kb
        do j=1,jm
          do i=1,im
            fb(i,j,k)=fb(i,j,k)+fclim(i,j,k)
          end do
        end do
      end do

! add net horizontal fluxes and step forward in time
      do k=1,kbm1
        do j=2,jmm1
          do i=2,imm1
            ff(i,j,k)=ff(i,j,k)-dti2*(xflux(i+1,j,k)-xflux(i,j,k)
     $                               +yflux(i,j+1,k)-yflux(i,j,k))
     $                           /((h(i,j)+etf(i,j))*art(i,j))
          end do
        end do
      end do

! diag
      do k=1,kbm1
        do j=2,jmm1
          do i=2,imm1
            xdifterm(i,j,k)=-(xflux(i+1,j,k)-xflux(i,j,k))
     $                       /((h(i,j)+etf(i,j))*art(i,j))
            ydifterm(i,j,k)=-(yflux(i,j+1,k)-yflux(i,j,k))
     $                       /((h(i,j)+etf(i,j))*art(i,j))
          end do
        end do
      end do

      return
      end


!-----collection of functions--------------------------------g.guidati--
!
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             functions for odeint
!
!.......................................................................
!               declarations
!.......................................................................

      subroutine SIG(s,y,dydx)

      USE TINoiseGeneric
      USE TINoiseGeo
      USE TINoiseDDD
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: k,khi,klo,i

REAL(DbKi)                   :: s,y1,y2,d1s,d2s,r2,r4,r6
REAL(DbKi)                   :: n1, n2,d1,d2,d1y1,d1y2,adds,dump
REAL(DbKi)                   :: y(6), dydx (6)

      call SPL_EX  (swork,n+1,s,khi,klo)
      call SPL_EX1 (swork,yc1,d2yc1,n+1,s,y1,d1y1,khi,klo)
      call SPL_EX1 (swork,yc2,d2yc2,n+1,s,y2,d1y2,khi,klo)
      CALL SPL_EX1 (swork, pots, d2pots, n+1, s, adds, dump, khi, klo)

      n1 =  d1y2
      n2 = -d1y1
      d1 = x1-y1
      d2 = x2-y2
      d1s = d1**2
      d2s = d2**2
      r2 = d1s + d2s
      r4 = r2 ** 2
      r6 = r2 ** 3

      dydx(1) =  (n1*d1+n2*d2)/r2* adds * pi2i
      dydx(2) =  (n1*(d2s-d1s)-2.0d0*n2*d2*d1)/r4 * adds * pi2i
      dydx(3) =  (n2*(d1s-d2s)-2.0d0*n1*d2*d1)/r4 * adds * pi2i
      dydx(4) = +(d1s*(2.0d0*n1*d1+6.0d0*n2*d2)- d2s*(6.0d0*n1*d1+2.0d0*n2*d2))/r6* adds *pi2i
      dydx(5) = +(d1s*(6.0d0*n1*d2-2.0d0*n2*d1)+ d2s*(6.0d0*n2*d1-2.0d0*n1*d2))/r6* adds *pi2i
      dydx(6) = +(d2s*(2.0d0*n2*d2+6.0d0*n1*d1)- d1s*(6.0d0*n2*d2+2.0d0*n1*d1))/r6* adds *pi2i

      return
      end

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

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

      subroutine SIGSPL(s,y,dydx)
      USE TINoiseGeneric
      USE TINoiseDDD
      USE TINoiseRHSin
      USE TIPrecision
      IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: k,khi,klo,i

REAL(DbKi)                   :: s,y1,y2,d1s,d2s,r2,r4,r6
REAL(DbKi)                   :: n1, n2,d1,d2,d1y1,d1y2,dsdt,arg
REAL(DbKi)                   :: y(6), dydx (6)

COMPLEX(DbKi)                :: pott, d1pott, green, HANK1, HANK0, HA0,HA1
COMPLEX(DbKi)                :: dkern1, dkern2, dkern3, dkern4, dkern5, dkern6
COMPLEX(DbKi)                :: gr, gr1, gr2, gr11, gr12, gr22, dumpa
COMPLEX(DbKi)                :: poadd,poads,d1azzz

!      call SPL_EX  (sworkat,na+1,s,khi,klo)
      khi = min(int(na+1),int(s+2))
!      khi = s + 2
      klo = khi-1
      call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,s,y1,d1y1,khi,klo)
      call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,s,y2,d1y2,khi,klo)
      CALL SPL_E1A (sworkat,potsat(1,ipath),d2potsat(1,ipath),na+1,s,pott,d1pott,khi,klo)

      dsdt = sqrt( d1y1**2 + d1y2**2)
      n1 =  d1y2 / dsdt
      n2 = -d1y1 / dsdt
      d1 = x1-y1
      d2 = x2-y2
      d1s = d1**2
      d2s = d2**2
      r2 = d1s + d2s
      arg = r2 * kwave2
!
!     HANK1(x**2) = HANK1 / x !!!!!!
!
!

      HA0  = HANK0(arg)
      HA1  = HANK1(arg)
      gr    = -0.25d0*imag*HA0
      gr1   = abb1*d1*HA1
      gr2   = abb1*d2*HA1
      dkern1 = ((n1*gr1 + n2*gr2) * pott) * dsdt
      dydx( 1) =  dble(dkern1)
      dydx( 2) =  dble(-imag*dkern1)

      if(lderiv) then
        gr11  = abb1*(HA0*d1s/r2+(1.0d0-2.0d0*d1s/r2)*HA1)
        gr12  = abb1*d1*d2/r2*(HA0-2.0d0*HA1)
        gr22  = abb1*(HA0*d2s/r2+(1.0d0-2.0d0*d2s/r2)*HA1)
        dkern2 = ((n1 * gr11 + n2 * gr12) * pott ) * dsdt
        dkern3 = ((n1 * gr12 + n2 * gr22) * pott ) * dsdt
        dydx( 3) =  dble(dkern2)
        dydx( 4) =  dble(-imag*dkern2)
        dydx( 5) =  dble(dkern3)
        dydx( 6) =  dble(-imag*dkern3)
      else
        dydx( 3) = 0.0
        dydx( 4) = 0.0
        dydx( 5) = 0.0
        dydx( 6) = 0.0
      endif

      return
      end

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

      subroutine SIGSUM(s,y,dydx)
      USE TINoiseGeneric
      USE TINoiseDDD
      USE TINoiseRHSin
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: k,khi,klo,i

REAL(DbKi)                   :: s,y1,y2,d1s,d2s,r2,r4,r6
REAL(DbKi)                   :: n1, n2,d1,d2,d1y1,d1y2,dsdt,arg
REAL(DbKi)                   :: y(10), dydx (10)

COMPLEX(DbKi)                :: pott, d1pott, green, HANK1, HANK0, HA0,HA1
COMPLEX(DbKi)                :: dkern1, dkern2, dkern3, dkern4, dkern5, dkern6
COMPLEX(DbKi)                :: gr, gr1, gr2, gr11, gr12, gr22, gr111, gr112
COMPLEX(DbKi)                :: gr122, gr222, dipstr, dumpa
COMPLEX(DbKi)                :: poadd,poads,d1azzz

!      call SPL_EX  (sworkat,na+1,s,khi,klo)
      khi = min(int(na+1),int(s+2))
      klo = khi-1
      call SPL_EX1 (sworkat,yc1at,d2yc1at,na+1,s,y1,d1y1,khi,klo)
      call SPL_EX1 (sworkat,yc2at,d2yc2at,na+1,s,y2,d1y2,khi,klo)
      CALL SPL_E1A (sworkat,potsum,d2potsum,na+1,s,pott,d1pott,khi,klo)

!      a = (sworkat(khi) - s)
!      b = (s - sworkat(klo))
!      a2 = a*a
!      b2 = b*b
!      a3 = a2*a
!      b3 = b2*b
!      a3ma = (a3-a) /6.
!      b3mb = (b3-b) /6.
!      a2p1 = (-3.0d0*a2 + 1.0d0)/6.0d0
!c      b2p1 = (+3.0d0*b2 - 1.0d0)/6.0d0
!      y1 = a * yc1at(klo) + b * yc1at(khi)
!     >     + (a3ma * d2yc1at(klo) + b3mb * d2yc1at(khi))
!      y2 = a * yc2at(klo) + b * yc2at(khi)
!     >     + (a3ma * d2yc2at(klo) + b3mb * d2yc2at(khi))
!      pott = a * potsat(klo,ipath) + b * potsat(khi,ipath)
!     >     + (a3ma * d2potsat(klo,ipath) +
!     +        b3mb * d2potsat(khi,ipath))
!      d1y1 = (-yc1at(klo) + yc1at(khi))
!     >       + (a2p1 * d2yc1at(klo)+b2p1 * d2yc1at(khi))
!      d1y2 = (-yc2at(klo) + yc2at(khi))
!     >       + (a2p1 * d2yc2at(klo)+b2p1 * d2yc2at(khi))

      dsdt = sqrt( d1y1**2 + d1y2**2)
      n1 =  d1y2 / dsdt
      n2 = -d1y1 / dsdt
      d1 = x1-y1
      d2 = x2-y2
      d1s = d1**2
      d2s = d2**2
      r2 = d1s + d2s
      arg = r2 * kwave2
!
!     HANK1(x**2) = HANK1 / x !!!!!!
!
!

      HA0  = HANK0(arg)
      HA1  = HANK1(arg)
      gr    = -0.25d0*imag*HA0
      gr1   = abb1*d1*HA1
      gr2   = abb1*d2*HA1
      dkern1 = ((n1*gr1 + n2*gr2) * pott ) * dsdt
      dydx( 1) =  dble(dkern1)
      dydx( 2) =  dble(-imag*dkern1)

      if(lderiv) then
        gr11  = abb1*(HA0*d1s/r2+(1.0d0-2.0d0*d1s/r2)*HA1)
        gr12  = abb1*d1*d2/r2*(HA0-2.0d0*HA1)
        gr22  = abb1*(HA0*d2s/r2+(1.0d0-2.0d0*d2s/r2)*HA1)
        gr111 = abb1*d1/r2*(-kwave2*d1s+8.0d0*d1s/r2-6.0d0)*HA1+abb1*d1/r2*(-4.0d0*d1s/r2+3.0d0)*HA0
        gr222 = abb1*d2/r2*(-kwave2*d2s+8.0d0*d2s/r2-6.0d0)*HA1+abb1*d2/r2*(-4.0d0*d2s/r2+3.0d0)*HA0
        gr112 = -kwave2 * gr2 - gr222
        gr122 = -kwave2 * gr1 - gr111

        dkern2 = ((n1 * gr11 + n2 * gr12) * pott ) * dsdt
        dkern3 = ((n1 * gr12 + n2 * gr22) * pott ) * dsdt
        dkern4 = ((n1 * gr111+ n2 *gr112) * pott ) * dsdt
        dkern5 = ((n1 * gr112+ n2 *gr122) * pott ) * dsdt
        dydx( 3) =  dble(dkern2)
        dydx( 4) =  dble(-imag*dkern2)
        dydx( 5) =  dble(dkern3)
        dydx( 6) =  dble(-imag*dkern3)
        dydx( 7) =  dble(dkern4)
        dydx( 8) =  dble(-imag*dkern4)
        dydx( 9) =  dble(dkern5)
        dydx(10) =  dble(-imag*dkern5)
      else
        dydx( 3) = 0.0
        dydx( 4) = 0.0
        dydx( 5) = 0.0
        dydx( 6) = 0.0
	dydx( 7) = 0.0
        dydx( 8) = 0.0
      	dydx( 9) = 0.0
      	dydx(10) = 0.0
      endif

      return
      end

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

      subroutine CFIE_s(s,y,dydx)
      USE TINoiseGeneric
      USE TINoiseGeo
      USE TINoiseDDD
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

INTEGER(4)                   :: k,khi,klo,i

REAL(DbKi)                   :: s,y1,y2,d1s,d2s,r2,r4,r6,ppp,tang
REAL(DbKi)                   :: n1, n2,d1,d2,d1y1,d1y2,dsdt,arg
REAL(DbKi)                   :: y(3), dydx (3)

      call SPL_EX  (swork,n+1,s,khi,klo)
      call SPL_EX1 (swork,yc1,d2yc1,n+1,s,y1,d1y1,khi,klo)
      call SPL_EX1 (swork,yc2,d2yc2,n+1,s,y2,d1y2,khi,klo)
      CALL SPL_EX1 (swork, pots, d2pots, n+1, s, ppp, tang, khi, klo)

      n1 =  d1y2 !/ sqrt(d1y1**2+d1y2**2)
      n2 = -d1y1 !/ sqrt(d1y1**2+d1y2**2)
      d1 = x1-y1
      d2 = x2-y2
      d1s = d1**2
      d2s = d2**2
      r2 = d1s + d2s
      r4 = r2 ** 2

      dydx(1) = (n1*d1+n2*d2)/r2* ppp * pi2i
      dydx(2) = (n1*(d2s-d1s)-2.0d0*n2*d2*d1)/r4 * ppp * pi2i
      dydx(3) = (n2*(d1s-d2s)-2.0d0*n1*d2*d1)/r4 * ppp * pi2i

      return
      end

!***********************************************************************
REAL(DbKi) function ansatz(r)
      USE TIPrecision
      IMPLICIT                        NONE
      REAL(DbKi)                   :: r
      ansatz = r**2/4.0d0 + r**3/9.0d0
      return
      end function
!***********************************************************************
REAL(DbKi)  function ansatd(r)
      USE TIPrecision
      IMPLICIT                        NONE
      REAL(DbKi)                   :: r
      ansatd = 1.0d0 + r
      return
      end function
!***********************************************************************
REAL(DbKi) function dsatzo(r)
      USE TINoiseGeneric
      USE TIPrecision
      IMPLICIT                        NONE
      REAL(DbKi)                   :: r
      dsatzo = 0.5+r/3.0d0
      return
      end function


*----------------------------------------------------------------------|
      subroutine DNCHBV( m, t, H,ldh, y, wsp )

      implicit none
      integer          m, ldh
      double precision t, H(ldh,m), y(m)
      complex*16       wsp(m*(m+2))

*-----Purpose----------------------------------------------------------|
*
*---  DNCHBV computes y = exp(t*H)*y using the partial fraction
*     expansion of the uniform rational Chebyshev approximation
*     to exp(-x) of type (14,14). H is assumed to be upper-Hessenberg.
*     About 14-digit accuracy is expected if the matrix H is negative
*     definite. The algorithm may behave poorly otherwise.
*
*-----Arguments--------------------------------------------------------|
*
*     m       : (input) order of the Hessenberg matrix H
*
*     t       : (input) time-scaling factor (can be < 0).
*
*     H(ldh,m): (input) upper Hessenberg matrix.
*
*     y(m)    : (input/output) on input the operand vector,
*               on output the resulting vector exp(t*H)*y.
*
*     wsp     : (workspace). Observe that a double precision vector of
*               length 2*m*(m+2) can be used as well when calling this
*               routine (thus avoiding an idle complex array elsewhere)
*
*----------------------------------------------------------------------|
*     Roger B. Sidje (rbs@maths.uq.edu.au)
*     EXPOKIT: Software Package for Computing Matrix Exponentials.
*     ACM - Transactions On Mathematical Software, 24(1):130-156, 1998
*----------------------------------------------------------------------|
*
      complex*16 ZERO
      integer ndeg, i, j, k, ip, ih, iy, iz
      parameter ( ndeg=7, ZERO=(0.0d0,0.0d0) )
      double precision alpha0
      complex*16 alpha(ndeg), theta(ndeg), tmpc

      intrinsic ABS,DBLE,MIN

*---  Pointers ...

      ih = 1
      iy = ih + m*m
      iz = iy + m

*---  Coefficients and poles of the partial fraction expansion...

      alpha0  =  0.183216998528140087D-11
      alpha(1)=( 0.557503973136501826D+02,-0.204295038779771857D+03)
      alpha(2)=(-0.938666838877006739D+02, 0.912874896775456363D+02)
      alpha(3)=( 0.469965415550370835D+02,-0.116167609985818103D+02)
      alpha(4)=(-0.961424200626061065D+01,-0.264195613880262669D+01)
      alpha(5)=( 0.752722063978321642D+00, 0.670367365566377770D+00)
      alpha(6)=(-0.188781253158648576D-01,-0.343696176445802414D-01)
      alpha(7)=( 0.143086431411801849D-03, 0.287221133228814096D-03)

      theta(1)=(-0.562314417475317895D+01, 0.119406921611247440D+01)
      theta(2)=(-0.508934679728216110D+01, 0.358882439228376881D+01)
      theta(3)=(-0.399337136365302569D+01, 0.600483209099604664D+01)
      theta(4)=(-0.226978543095856366D+01, 0.846173881758693369D+01)
      theta(5)=( 0.208756929753827868D+00, 0.109912615662209418D+02)
      theta(6)=( 0.370327340957595652D+01, 0.136563731924991884D+02)
      theta(7)=( 0.889777151877331107D+01, 0.166309842834712071D+02)
*
*---  Accumulation of the contribution of each pole ...
*
      do j = 1,m
         wsp(iz+j-1) = y(j)
         y(j) = y(j)*alpha0
      enddo
      do ip = 1,ndeg
*---     Solve each fraction using Gaussian elimination with pivoting...
         do j = 1,m
            wsp(iy+j-1) = wsp(iz+j-1)
            do i = 1,MIN( j+1,m )
               wsp(ih+(j-1)*m+i-1) = -t*H(i,j)
            enddo
            wsp(ih+(j-1)*m+j-1) = wsp(ih+(j-1)*m+j-1)-theta(ip)
            do k = i,m
               wsp(ih+(j-1)*m+k-1) = ZERO
            enddo
         enddo
         do i = 1,m-1
*---        Get pivot and exchange rows ...
            if (ABS(wsp(ih+(i-1)*m+i-1)).lt.ABS(wsp(ih+(i-1)*m+i))) then
               call ZSWAP( m-i+1, wsp(ih+(i-1)*m+i-1),m,
     .                     wsp(ih+(i-1)*m+i),m )
               call ZSWAP( 1, wsp(iy+i-1),1, wsp(iy+i),1 )
            endif
*---        Forward eliminiation ...
            tmpc = wsp(ih+(i-1)*m+i) / wsp(ih+(i-1)*m+i-1)
            call ZAXPY( m-i, -tmpc, wsp(ih+i*m+i-1),m, wsp(ih+i*m+i),m )
            wsp(iy+i) = wsp(iy+i) - tmpc*wsp(iy+i-1)
         enddo
*---     Backward substitution ...
         do i = m,1,-1
            tmpc = wsp(iy+i-1)
            do j = i+1,m
               tmpc = tmpc - wsp(ih+(j-1)*m+i-1)*wsp(iy+j-1)
            enddo
            wsp(iy+i-1) = tmpc / wsp(ih+(i-1)*m+i-1)
         enddo
*---     Accumulate the partial result in y ...
         do j = 1,m
            y(j) = y(j) + DBLE( alpha(ip)*wsp(iy+j-1) )
         enddo
      enddo
      END
*----------------------------------------------------------------------|


      SUBROUTINE PGS(SWFACP,STRESS_PHO,STRESS_K,STRESS_N,CHUPIBASE,PAR,LAI,PG,RESP,DIAC,TMN,W,CCEFF,CCMAX,k,PHTMAX,CCMP,PARMAX)

!*****************************************************************************
!*     Subroutine PGS
!*     Calculates the canopy gross photosysntesis rate (PG)
!*     Input: SWFACP,PAR,LAI,DIAC,TMN,W,CCEFF,CCMAX,k,PHTMAX,PARMAX,PTSMAX)
!*     Output: PG,RESP
!*     FABIO MARIN
!******************************************************************************

      IMPLICIT NONE
      REAL PAR,LAI,DIac,RESP,LI,PG,E_FAC,PRATIO,STRESS_PHO,STRESS_K,STRESS_N
      REAL SWFACE,SWFACP,ROWSPC,W,AGEFACTOR,PSTRES2
      REAL CCK,CCEFF,CCMAX,k,PHTMAX,PARMAX,PTSMAX
      REAL A0,CCMP,CO2,CT,CHUPIBASE,TMN

!Original Equation - Some of the varaibles were taken out because the lack of relationship with
!Sugarcane or the lack of time to develop it in time for this version

      CO2 = 380.

!-----------------------------------------------------------------------
!     Calculate maximum photosynthesis as function of PAR, g CH2O/m2
!-----------------------------------------------------------------------
      PAR = PAR * 3.969354729                                   !The multiplier for PAR is to convert
      PTSMAX = PHTMAX * (1.0 - EXP(-(1.0 / PARMAX) * (PAR)))    !PAR (MJ/m2.d) to (moles/m2.d).
                                                                !See Sheet c:\canemodel\Photosynthesis_Cropgro.xls
!-----------------------------------------------------------------------
!     Calculate reduction in photosynthesis due to incomplete canopy.
!-----------------------------------------------------------------------
      LI    = 1. - EXP(-k * LAI) ! Replacing LIalt in the PG's equation.
! FM - The code should include the effect of N stress. It should be included in second phase of the model.

!-----------------------------------------------------------------------
!     Adjust canopy photosynthesis for CO2 concentration assuming a
!     reference value of CO2 of 330 ppmv. Thus, it computes daily gross canopy
!     photosynthesis (g[CH2O]/m2-d).
!-----------------------------------------------------------------------
      CCK = CCEFF / CCMAX !CCK is QE in Alagarswamy et al. - it means "quantum efficiency of the leaf"
      A0 = -CCMAX * (1. - EXP(-CCK * CCMP)) ! CCMAX is the AMax in the same paper. It means the Maximum A
      PRATIO = A0 + CCMAX * (1. - EXP(-CCK * CO2))

!Compute daily gross photosynthesis (g CH2O/m2 leaf/d)
      PSTRES2 = 1.0 ! it'll be kept equal 1 untill Phosphorus algorithm had been finished
!      AGEFACTOR = EXP(-0.000401*(DIAC-(CHUPIBASE+2000))) ! it'll be kept equal 1 untill N Stress algorithm had been finished
      AGEFACTOR = EXP(-0.000401*(DIAC-(2000))) ! Changed to reduce the photosynthesis rates after a while
      AGEFACTOR = MIN(1.,AGEFACTOR)

	!		AGEFACTOR = EXP(-0.000401*(DIAC-CHUPIBASE)) ! Factor is an age reduction factor for dPER, based on N. G. Inman-Bamber et al. 2008 Australian Journal of Agricultural Research, Fig.3
    !        AGEFACTOR = MIN(1.,AGEFACTOR)

!E_FAC - Effect of N and/or P stress on canopy photosynthesis (0-1). KEEP 1 UNTIL ADVANCES
      IF (SWFACP < .99) THEN
        E_FAC = AGEFACTOR * SWFACP *  STRESS_N * STRESS_K * STRESS_PHO !Changed in 11/5/2010 to reduce the photosynthesis rates after a while
      ELSE
        E_FAC = 1. !AGEFACTOR
      ENDIF

!COMPUTING GROSS PHOTOSYNTHESIS without stress during the first days
    PG = PTSMAX * LI * E_FAC * PRATIO   !  (g m-2 leaf d-1)
    PG = PG / 1000 ! (converting to kg m-2 leaf d-1)

! COMPUTING RESPIRATION from original equation of McCree (1974).
! It was assumed the same coefficients from Grain Sorghum do compute daily Photosynthesis
	  CT = (0.044 + 0.0019 * TMN + 0.001 * (TMN**2))   *.0108 ! EQUATION 5 FROM MCCREE (1974). .0054 is the
      !Coefficient for Sorghum. They are giving an response similar to that measure by Bull et al, apud Singels et al. (2005)

      !convert from ton ha-1 to kg m-2
      w = w / 10.

      RESP = 0.14 * PG + CT * (W)    !(kg m-2 leaf d-1)

      RETURN
    END SUBROUTINE PGS


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2015-2015 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module FourierTransform3D_
	use FFTW3_
	use GOptions_
	use Math_
	use Grid3D_
	use CNFunction3D_
	use RNFunction3D_
	use RandomUtils_
	use FourierTransform_
	use FourierTransform2D_
	implicit none
	private

	public :: &
		FourierTransform3D_omegaGrid, &
		FourierTransform3D_xyzGrid, &
		FourierTransform3D_phase, &
		FourierTransform3D_iphase, &
		FourierTransform3D_shift, &
		FourierTransform3D_ishift, &
		FourierTransform3D_plan, &
		FourierTransform3D_execute, &
		FourierTransform3D_destroyPlan, &
		FourierTransform3D_dft, &
		FourierTransform3D_idft, &
		FourierTransform3D_fft, &
		FourierTransform3D_ifft, &
		FourierTransform3D_nft, &
		FourierTransform3D_inft, &
		FourierTransform3D_test

	type, public :: FourierTransform3D
		class(CNFunction3D), pointer, private :: iFunc
		integer(8), private :: planF, planB

		integer :: nPoints(3)
		type(Grid3D) :: x
		type(Grid3D) :: omega

		contains
			procedure :: init
			final :: destroy
			procedure :: str
			procedure :: show
			procedure :: execute
! 			procedure :: filter
	end type FourierTransform3D

    interface FourierTransform3D_omegaGrid
		module procedure FourierTransform3D_omegaGridFromData
		module procedure FourierTransform3D_omegaGridFromXGrid
    end interface FourierTransform3D_omegaGrid

    interface FourierTransform3D_xyzGrid
		module procedure FourierTransform3D_xyzGridFromData
		module procedure FourierTransform3D_xyzGridFromOmegaGrid
    end interface FourierTransform3D_xyzGrid

    interface FourierTransform3D_phase
        module procedure FourierTransform3D_phase_realArray
        module procedure FourierTransform3D_phase_complexArray
        module procedure FourierTransform3D_phase_RNFunction3D
        module procedure FourierTransform3D_phase_CNFunction3D
    end interface FourierTransform3D_phase

    interface FourierTransform3D_iphase
        module procedure FourierTransform3D_iphase_realArray
        module procedure FourierTransform3D_iphase_complexArray
        module procedure FourierTransform3D_iphase_CNFunction3D
    end interface FourierTransform3D_iphase

    interface FourierTransform3D_shift
        module procedure FourierTransform3D_shift_Grid
        module procedure FourierTransform3D_shift_RNFunction3D
        module procedure FourierTransform3D_shift_CNFunction3D
    end interface FourierTransform3D_shift

    interface FourierTransform3D_ishift
        module procedure FourierTransform3D_ishift_Grid
        module procedure FourierTransform3D_ishift_CNFunction3D
    end interface FourierTransform3D_ishift

    interface FourierTransform3D_plan
        module procedure FourierTransform3D_plan_Array
        module procedure FourierTransform3D_plan_CNFunction3D
    end interface FourierTransform3D_plan

    interface FourierTransform3D_dft
        module procedure FourierTransform3D_dft_CArray
    end interface FourierTransform3D_dft

    interface FourierTransform3D_idft
        module procedure FourierTransform3D_idft_Array
    end interface FourierTransform3D_idft

    interface FourierTransform3D_fft
        module procedure FourierTransform3D_fft_CNFunction3D
    end interface FourierTransform3D_fft

    interface FourierTransform3D_ifft
        module procedure FourierTransform3D_ifft_CNFunction3D
    end interface FourierTransform3D_ifft

    interface FourierTransform3D_nft
        module procedure FourierTransform3D_nft_CNFunction3D
    end interface FourierTransform3D_nft

    interface FourierTransform3D_inft
        module procedure FourierTransform3D_inft_CNFunction3D
    end interface FourierTransform3D_inft

	contains

	!>
	!! @brief Constructor
	!! @todo En algunas ocasiones es importante hacer la transfomada de no todos los puntos
	!!
	subroutine init( this, iFunc, domain, oFunc )
		class(FourierTransform3D) :: this
		class(CNFunction3D), target, intent(in) :: iFunc
		integer(8), intent(in), optional :: domain
		class(CNFunction3D), target, optional, intent(in) :: oFunc

		integer(8) :: effDomain

		integer :: nx, ny, nz

		if( associated(this.iFunc) ) nullify(this.iFunc)
		this.iFunc => iFunc
		this.nPoints = iFunc.nPoints() ! << Hay que cambiar para hacer la transformada de algunos puntos

		nx = this.nPoints(1)
		ny = this.nPoints(2)
		nz = this.nPoints(3)

		effDomain = FourierTransform_SPATIAL_DOMAIN
		if( present(domain) ) effDomain = domain

		if( present(oFunc) ) call GOptions_error( "oFunc parameter is not implamented yet", "FourierTransform3D.init()" )

		call dfftw_plan_dft_3d( this.planF, nx, ny, nz, this.iFunc.fArray, this.iFunc.fArray, FFTW_FORWARD, FFTW_ESTIMATE )
		call dfftw_plan_dft_3d( this.planB, nx, ny, nz, this.iFunc.fArray, this.iFunc.fArray, FFTW_BACKWARD, FFTW_ESTIMATE )

		if( effDomain == FourierTransform_SPATIAL_DOMAIN ) then

			this.x = this.iFunc.xyzGrid ! << Hay que cambiar para hacer la transformada de algunos puntos
			this.omega = FourierTransform3D_omegaGrid( this.x )

		else if( effDomain == FourierTransform_FREQUENCY_DOMAIN ) then

			call GOptions_warning( "FourierTransform_FREQUENCY_DOMAIN have not been tested yet", "FourierTransform.init()" )
			this.omega = this.iFunc.xyzGrid ! << Hay que cambiar para hacer la transformada de algunos puntos
			this.x = FourierTransform3D_xyzGrid( this.omega )

		end if
	end subroutine init

	!>
	!! @brief Destructor
	!!
	subroutine destroy( this )
		type(FourierTransform3D) :: this

		! Si los activo el programa produce:
		! 	forrtl: error (76): Abort trap signal
! 		call dfftw_destroy_plan( this.planF )
! 		call dfftw_destroy_plan( this.planB )

		nullify(this.iFunc)

		this.nPoints = -1
	end subroutine destroy

	!>
	!! @brief
	!!
	function str( this ) result( output )
		class(FourierTransform3D) :: this
		character(len=200) :: output

		integer :: fmt
		character(len=200) :: strBuffer

		output = ""

		output = trim(output)//"<FourierTransform3D:"

! 		output = trim(output)//"min="
! 		fmt = int(log10(this.min+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.min
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",max="
! 		fmt = int(log10(this.max+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.max
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",h="
! 		fmt = int(log10(this.h+1.0))+1
! 		write(strBuffer, "(f<fmt+7>.6)") this.h
! 		output = trim(output)//trim(strBuffer)
!
! 		output = trim(output)//",size="
! 		fmt = int(log10(float(this.size+1)))+1
! 		write(strBuffer, "(i<fmt>)") this.size
! 		output = trim(output)//trim(strBuffer)

		output = trim(output)//">"
	end function str

	!>
	!! @brief
	!!
	subroutine show( this, unit )
		class(FourierTransform3D) :: this
		integer, optional, intent(in) :: unit

		integer :: effunit

		if( present(unit) ) then
			effunit = unit
		else
			effunit = 6
		end if

		write(effunit,"(a)") trim(this.str())
	end subroutine show

	!>
	!! @brief
	!!
	subroutine execute( this, sgn, sync, shift )
		class(FourierTransform3D) :: this
		integer, intent(in) :: sgn
		logical, optional, intent(in) :: sync
		logical, optional, intent(in) :: shift

		logical :: effSync
		logical :: effShift

		effSync = .false.
		if( present(sync) ) effSync = sync

		effShift = .false.
		if( present(shift) ) effShift = shift

		if( sgn == FourierTransform_FORWARD ) then

			call dfftw_execute( this.planF )

			if( effSync ) then
				this.iFunc.xyzGrid = this.omega

				if( effShift ) then
					call FourierTransform3D_phase( this.iFunc )
					call FourierTransform3D_shift( this.iFunc )
				end if
			end if

		else if ( sgn == FourierTransform_BACKWARD ) then

			if( effSync ) then
				if( effShift ) then
					call FourierTransform3D_ishift( this.iFunc )
					call FourierTransform3D_phase( this.iFunc )
				end if
			end if

			call dfftw_execute( this.planB )

			if( effSync ) then
				this.iFunc.xyzGrid = this.x
			end if

			this.iFunc = this.iFunc/real(this.nPoints(1)*this.nPoints(2)*this.nPoints(3),8)

		else
			call GOptions_error( "Bad value for sgn", "FourierTransform3D.execute()" )
		end if
	end subroutine execute

	!>
	!! @brief
	!!
	function FourierTransform3D_omegaGridFromData( n, h, order ) result( output )
		integer, intent(in) :: n(3)
		real(8), optional, intent(in) :: h(3)
		integer, optional, intent(in) :: order
		type(Grid3D) :: output

		integer :: i

		do i=1,3
			output.component(i) = FourierTransform_omegaGrid( n(i), h(i), order=order )
		end do
	end function FourierTransform3D_omegaGridFromData

	!>
	!! @brief
	!!
	function FourierTransform3D_omegaGridFromXGrid( xyzGrid, order ) result( output )
		type(Grid3D), intent(in) :: xyzGrid
		integer, optional, intent(in) :: order
		type(Grid3D) :: output

		output = FourierTransform3D_omegaGridFromData( xyzGrid.nPointsVec(), xyzGrid.stepSize(), order=order )
	end function FourierTransform3D_omegaGridFromXGrid

	!>
	!! @brief
	!!
	function FourierTransform3D_xyzGridFromData( n, h, order ) result( output )
		integer, intent(in) :: n(3)
		real(8), intent(in) :: h(3)
		integer, optional, intent(in) :: order
		type(Grid3D) :: output

		integer :: i

		do i=1,3
			output.component(i) = FourierTransform_xGrid( n(i), h(i), order=order )
		end do
	end function FourierTransform3D_xyzGridFromData

	!>
	!! @brief
	!!
	function FourierTransform3D_xyzGridFromOmegaGrid( omegaGrid, order ) result( output )
		type(Grid3D), intent(in) :: omegaGrid
		integer, optional, intent(in) :: order
		type(Grid3D) :: output

		real(8) :: dx(3)

		! dx = 2*pi/n/dp
		dx = 2.0_8*MATH_PI/real(omegaGrid.nPoints(),8)/omegaGrid.stepSize()

		output = FourierTransform3D_xyzGridFromData( omegaGrid.nPoints(), dx, order=order )
	end function FourierTransform3D_xyzGridFromOmegaGrid

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_phase_realArray( iArray, oArray )
		real(8) :: iArray(:)
		real(8), optional :: oArray(:)

! 		integer :: i, j, n, p0
!
! 		n = size( iArray )
! 		p0 = floor( n/2.0_8 )+2
!
! 		i = 1
! 		do j=p0,n
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**j
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**j
! 			end if
!
! 			i = i+1
! 		end do
!
! 		do j=1,p0-1
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**j
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**j
! 			end if
!
! 			i = i+1
! 		end do
	end subroutine FourierTransform3D_phase_realArray

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_phase_complexArray( iArray, oArray )
		complex(8) :: iArray(:)
		complex(8), optional :: oArray(:)

! 		integer :: i, j, n, p0
!
! 		n = size( iArray )
! 		p0 = floor( n/2.0_8 )+2
!
! 		i = 1
! 		do j=p0,n
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**j
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**j
! 			end if
!
! 			i = i+1
! 		end do
!
! 		do j=1,p0-1
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**j
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**j
! 			end if
!
! 			i = i+1
! 		end do
	end subroutine FourierTransform3D_phase_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_iphase_realArray( iArray, oArray )
		real(8) :: iArray(:)
		real(8), optional :: oArray(:)

! 		integer :: i, j, n, p2
!
! 		n = size( iArray )
! 		p2 = n-floor(n/2.0_8)
!
! 		i = 1
! 		do j=p2,n
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
!
! 		do j=1,p2-1
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
	end subroutine FourierTransform3D_iphase_realArray

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_iphase_complexArray( iArray, oArray )
		complex(8) :: iArray(:)
		complex(8), optional :: oArray(:)

! 		integer :: i, j, n, p2
!
! 		n = size( iArray )
! 		p2 = n-floor(n/2.0_8)
!
! 		i = 1
! 		do j=p2,n
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
!
! 		do j=1,p2-1
! 			if( present(oArray) ) then
! 				oArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			else
! 				iArray(i) = iArray(i)*(-1.0_8)**(j-1)
! 			end if
!
! 			i = i+1
! 		end do
	end subroutine FourierTransform3D_iphase_complexArray

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_phase_RNFunction3D( iFunc, oFunc )
		class(RNFunction3D) :: iFunc
		class(RNFunction3D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform3D_phase_RNFunction3D()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_phase( oFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_phase( oFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_phase( oFunc.fArray(:,:,i) )
			end do
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_phase( iFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_phase( iFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_phase( iFunc.fArray(:,:,i) )
			end do
		end if
	end subroutine FourierTransform3D_phase_RNFunction3D

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_phase_CNFunction3D( iFunc, oFunc )
		class(CNFunction3D) :: iFunc
		class(CNFunction3D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform3D_phase_CNFunction3D()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_phase( oFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_phase( oFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_phase( oFunc.fArray(:,:,i) )
			end do
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_phase( iFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_phase( iFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_phase( iFunc.fArray(:,:,i) )
			end do
		end if
	end subroutine FourierTransform3D_phase_CNFunction3D

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_iphase_CNFunction3D( iFunc, oFunc )
		class(CNFunction3D) :: iFunc
		class(CNFunction3D), optional :: oFunc

! 		if( .not. iFunc.isEquallyspaced() ) then
! 			call GOptions_warning( &
! 				"Grid should be equally spaced", &
! 				"FourierTransform3D_ishift_Grid()" &
! 			)
! 		end if
!
! 		if( present(oFunc) ) then
! 			oFunc = iFunc
!
! 			call FourierTransform3D_iphase_complexArray( oFunc.yArray )
! 		else
! 			call FourierTransform3D_iphase_complexArray( iFunc.yArray )
! 		end if
	end subroutine FourierTransform3D_iphase_CNFunction3D

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_shift_Grid( iGrid, oGrid )
		class(Grid3D) :: iGrid
		class(Grid3D), optional :: oGrid

		integer :: i

		if( iGrid.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform3D_shift_Grid()" &
			)
		end if

		if( present(oGrid) ) then
			oGrid = iGrid

			do i=1,3
				call FourierTransform_shift( oGrid.component(i) )
			end do
		else
			do i=1,3
				call FourierTransform_shift( iGrid.component(i) )
			end do
		end if

	end subroutine FourierTransform3D_shift_Grid

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_ishift_Grid( iGrid, oGrid )
		class(Grid3D) :: iGrid
		class(Grid3D), optional :: oGrid

		integer :: i

		if( .not. iGrid.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should be equally spaced", &
				"FourierTransform3D_ishift_Grid()" &
			)
		end if

		if( present(oGrid) ) then
			oGrid = iGrid

			do i=1,3
				call FourierTransform_ishift( oGrid.component(i) )
			end do
		else
			do i=1,3
				call FourierTransform_ishift( iGrid.component(i) )
			end do
		end if

	end subroutine FourierTransform3D_ishift_Grid

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_shift_RNFunction3D( iFunc, oFunc )
		class(RNFunction3D) :: iFunc
		class(RNFunction3D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform3D_shift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_shift( oFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_shift( oFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_shift( oFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_shift( oFunc.xyzGrid )
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_shift( iFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_shift( iFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_shift( iFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_shift( iFunc.xyzGrid )
		end if

	end subroutine FourierTransform3D_shift_RNFunction3D

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_shift_CNFunction3D( iFunc, oFunc )
		class(CNFunction3D) :: iFunc
		class(CNFunction3D), optional :: oFunc

		integer :: i

		if( iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should not be equally spaced", &
				"FourierTransform3D_shift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_shift( oFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_shift( oFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_shift( oFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_shift( oFunc.xyzGrid )
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_shift( iFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_shift( iFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_shift( iFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_shift( iFunc.xyzGrid )
		end if

	end subroutine FourierTransform3D_shift_CNFunction3D

	!>
	!! @brief
	!!
	subroutine FourierTransform3D_ishift_CNFunction3D( iFunc, oFunc )
		class(CNFunction3D) :: iFunc
		class(CNFunction3D), optional :: oFunc

		integer :: i

		if( .not. iFunc.isEquallyspaced() ) then
			call GOptions_warning( &
				"Grid should be equally spaced", &
				"FourierTransform3D_ishift_Grid()" &
			)
		end if

		if( present(oFunc) ) then
			oFunc = iFunc

			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_ishift( oFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_ishift( oFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_ishift( oFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_ishift( oFunc.xyzGrid )
		else
			do i=1,iFunc.nPoints(1)
				call FourierTransform2D_ishift( iFunc.fArray(i,:,:) )
			end do

			do i=1,iFunc.nPoints(2)
				call FourierTransform2D_ishift( iFunc.fArray(:,i,:) )
			end do

			do i=1,iFunc.nPoints(3)
				call FourierTransform2D_ishift( iFunc.fArray(:,:,i) )
			end do

			call FourierTransform3D_ishift( iFunc.xyzGrid )
		end if

	end subroutine FourierTransform3D_ishift_CNFunction3D

	!>
	!! @brief
	!!
	function FourierTransform3D_plan_Array( iArray, sgn, oArray ) result( plan )
		complex(8) :: iArray(:,:,:)
		integer, intent(in) :: sgn
		complex(8), optional :: oArray(:,:,:)
		integer(8) :: plan

		if( present(oArray) ) then
			call dfftw_plan_dft_3d( plan, size(iArray,dim=1), size(iArray,dim=2), size(iArray,dim=3), iArray, oArray, sgn, FFTW_ESTIMATE )
		else
			call dfftw_plan_dft_3d( plan, size(iArray,dim=1), size(iArray,dim=2), size(iArray,dim=3), iArray, iArray, sgn, FFTW_ESTIMATE )
		end if
	end function FourierTransform3D_plan_Array

	!>
	!! @brief
	!!
	function FourierTransform3D_plan_CNFunction3D( iFunc, sgn, oFunc ) result( plan )
		type(CNFunction3D) :: iFunc
		integer, intent(in) :: sgn
		type(CNFunction3D), optional :: oFunc
		integer(8) :: plan

		if( present(oFunc) ) then
			call dfftw_plan_dft_3d( plan, iFunc.nPoints(1), iFunc.nPoints(2), iFunc.nPoints(3), iFunc.fArray, oFunc.fArray, sgn, FFTW_ESTIMATE )
		else
			call dfftw_plan_dft_3d( plan, iFunc.nPoints(1), iFunc.nPoints(2), iFunc.nPoints(3), iFunc.fArray, iFunc.fArray, sgn, FFTW_ESTIMATE )
		end if
	end function FourierTransform3D_plan_CNFunction3D

	!>
	!!
	!!
	subroutine FourierTransform3D_execute( plan )
		integer(8), intent(in) :: plan

		call dfftw_execute( plan )
	end subroutine FourierTransform3D_execute

	!>
	!!
	!!
	subroutine FourierTransform3D_destroyPlan( plan )
		integer(8), intent(in) :: plan

		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform3D_destroyPlan

	!>
	!!
	!!
	subroutine FourierTransform3D_dft_CArray( iArray, oArray, sgn )
		complex(8) :: iArray(:,:,:)
		complex(8), optional :: oArray(:,:,:)
		integer, optional :: sgn

		integer :: effSgn

		integer(8) :: plan

		effSgn = FourierTransform_FORWARD
		if( present(sgn) ) effSgn = sgn

		if( present(oArray) ) then
			if( size(iArray) /= size(oArray) ) &
				call GOptions_error( "iArray and oArray have not the same size", "FourierTransform3D_dft_CArray" )

			call dfftw_plan_dft_3d( plan, size(iArray,dim=1), size(iArray,dim=2), size(iArray,dim=3), iArray, oArray, effSgn, FFTW_ESTIMATE )
			call dfftw_execute( plan )
		else
			call dfftw_plan_dft_3d( plan, size(iArray,dim=1), size(iArray,dim=2), size(iArray,dim=3), iArray, iArray, effSgn, FFTW_ESTIMATE )
			call dfftw_execute( plan )
		end if

		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform3D_dft_CArray

	!>
	!!
	!!
	subroutine FourierTransform3D_idft_Array( iArray, oArray, sgn )
		complex(8) :: iArray(:)
		complex(8), optional :: oArray(:)
		integer, optional :: sgn

		stop "FourierTransform3D_idft_Array is not implemented"
! 		integer :: effSgn
!
! 		integer(8) :: plan
!
! 		effSgn = FourierTransform3D_BACKWARD
! 		if( present(sgn) ) effSgn = sgn
!
! 		if( present(oArray) ) then
! 			if( size(iArray) /= size(oArray) ) &
! 				call GOptions_error( "iArray and oArray have not the same size", "FourierTransform3D_idft_Array" )
!
! 			call dfftw_plan_dft_1d( plan, size(iArray), iArray, oArray, effSgn, FourierTransform3DW_ESTIMATE )
! 			call dfftw_execute( plan )
!
! 			oArray = oArray/real( size(iArray), 8 )
! 		else
! 			call dfftw_plan_dft_1d( plan, size(iArray), iArray, iArray, effSgn, FourierTransform3DW_ESTIMATE )
! 			call dfftw_execute( plan )
!
! 			iArray = iArray/real( size(iArray), 8 )
! 		end if
!
! 		call dfftw_destroy_plan( plan )
	end subroutine FourierTransform3D_idft_Array

	!>
	!!
	!!
	function FourierTransform3D_fft_CNFunction3D( iFunc, sgn ) result( oFunc )
		type(CNFunction3D) :: iFunc
		integer, optional :: sgn
		type(CNFunction3D) :: oFunc

		integer :: n(3)
		real(8) :: dx(3), dp(3)
		type(Grid3D) :: xyzGrid

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dx = iFunc.xyzGrid.stepSize()
		dp = 2.0_8*Math_PI/dx/real(n,8)

		oFunc = iFunc
		call FourierTransform3D_dft( iFunc.fArray, oFunc.fArray, sgn=FourierTransform_FORWARD )
		oFunc.xyzGrid = FourierTransform3D_omegaGrid( n, dx, order=FourierTransform_SORDER )

		call FourierTransform3D_phase( oFunc )
		call FourierTransform3D_shift( oFunc )

		oFunc = oFunc*dx(1)*dx(2)*dx(3)/sqrt(2.0_8*Math_PI)**3
	end function FourierTransform3D_fft_CNFunction3D

	!>
	!!
	!!
	function FourierTransform3D_ifft_CNFunction3D( iFunc, sgn ) result( oFunc )
		type(CNFunction3D) :: iFunc
		integer, optional :: sgn
		type(CNFunction3D) :: oFunc

		integer :: n(3)
		real(8) :: dx(3), dp(3)
		type(Grid3D) :: xyzGrid

		integer :: i

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dp = iFunc.xyzGrid.stepSize()
		dx = 2.0_8*Math_PI/dp/real(n,8)

		oFunc = iFunc

		call FourierTransform3D_ishift( oFunc )
		call FourierTransform3D_phase( oFunc )

		call FourierTransform3D_dft( oFunc.fArray, oFunc.fArray, sgn=FourierTransform_BACKWARD )
		oFunc.xyzGrid = FourierTransform3D_xyzGrid( n, dx, order=FourierTransform_NORDER )

		oFunc = oFunc*dp(1)*dp(2)*dp(3)/sqrt(2.0_8*Math_PI)**3
	end function FourierTransform3D_ifft_CNFunction3D

	!>
	!! @brief
	!!
	function FourierTransform3D_nft_CNFunction3D( iFunc, sgn ) result( oFunc )
		type(CNFunction3D), intent(in) :: iFunc
		integer, optional, intent(in) :: sgn
		type(CNFunction3D) :: oFunc

		integer :: effSgn

		integer :: iw, jw, kw, ix, jx, kx, n(3)
		real(8) :: dx(3), dp(3)
		type(Grid3D) :: xyzGrid

		effSgn = FourierTransform_FORWARD
		if( present(sgn) ) effSgn = sgn

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dx = iFunc.xyzGrid.stepSize()
		dp = 2.0_8*Math_PI/dx/real(n,8)

		oFunc = iFunc
		oFunc.xyzGrid = FourierTransform3D_omegaGrid( n, dx, order=FourierTransform_NORDER )
		call oFunc.xyzGrid.show()

		do kw=1,n(3); do jw=1,n(2); do iw=1,n(1)
			oFunc.fArray(iw,jw,kw) = 0.0_8
			do kx=1,n(3); do jx=1,n(2); do ix=1,n(1)
				oFunc.fArray(iw,jw,kw) = oFunc.fArray(iw,jw,kw) &
					+ iFunc.fArray(ix,jx,kx)*exp( real(effSgn,8)*Math_I*sum( iFunc.xyzGrid.at(ix,jx,kx)*oFunc.xyzGrid.at(iw,jw,kw) ) )
			end do; end do; end do
		end do; end do; end do

		oFunc = oFunc*dx(1)*dx(2)*dx(3)/(2.0_8*Math_PI)
	end function FourierTransform3D_nft_CNFunction3D

	!>
	!! @brief
	!!
	function FourierTransform3D_inft_CNFunction3D( iFunc, sgn ) result( oFunc )
		type(CNFunction3D), intent(in) :: iFunc
		integer, optional, intent(in) :: sgn
		type(CNFunction3D) :: oFunc

		integer :: effSgn

		integer :: iw, jw, kw, ix, jx, kx, n(3)
		real(8) :: dx(3), dp(3)
		type(Grid3D) :: xyzGrid

		effSgn = FourierTransform_BACKWARD
		if( present(sgn) ) effSgn = sgn

		! @todo Check for checkEquallyspaced
		n = iFunc.nPoints()
		dp = iFunc.xyzGrid.stepSize()
		dx = 2.0_8*Math_PI/dp/real(n,8)

		oFunc = iFunc
		oFunc.xyzGrid = FourierTransform3D_xyzGrid( n, dx, order=FourierTransform_NORDER )

		do kw=1,n(3); do jw=1,n(2); do iw=1,n(1)
			oFunc.fArray(iw,jw,kw) = 0.0_8
			do kx=1,n(3); do jx=1,n(2); do ix=1,n(1)
				oFunc.fArray(iw,jw,kw) = oFunc.fArray(iw,jw,kw) &
					+ iFunc.fArray(ix,jx,kx)*exp( real(effSgn,8)*Math_I*sum( iFunc.xyzGrid.at(ix,jx,kx)*oFunc.xyzGrid.at(iw,jw,kw) ) )
			end do; end do; end do
		end do; end do; end do

		oFunc = oFunc*dp(1)*dp(2)*dp(3)/(2.0_8*Math_PI)
	end function FourierTransform3D_inft_CNFunction3D

	!>
	!! This is neccesary only for FourierTransform3D_test()
	!! Maxima:
	!!   f(x) := exp(-0.5*x**2);
	!!
	function funcGaussian( x, y, z ) result( output )
		real(8), intent(in) :: x, y, z
		complex(8) :: output

		real(8) :: alpha

		alpha = 5.0_8
		output = exp(-alpha*( x**2 + y**2 + z**2 ))
	end function funcGaussian

	!>
	!! This is neccesary only for FourierTransform3D_test()
	!! Maxima:
	!!   f(x) := exp(-0.5*x**2);
	!!
	!! La convencion de normalizacion de acuerdo con wikipedia es:
    !!   Fourier transform unitary, angular frequency
	!!
	function funcFGaussian( x ) result( output )
		real(8), intent(in) :: x
		complex(8) :: output

		real(8) :: alpha

		alpha = 0.5_8
! 		output = exp(-x**2/4.0_8/alpha)/sqrt(2.0_8*alpha)
		output = exp(-(x-5.0_8)**2/4.0_8/alpha)/sqrt(2.0_8*alpha) + 0.4_8*exp(-(x+2.0_8)**2/10.0_8/alpha)/sqrt(2.0_8*alpha)*sin(2.0*x) &
			+ 0.4_8*Math_I*exp(-(x-2.0_8)**2/10.0_8/alpha)/sqrt(2.0_8*alpha)*cos(2.0*x)
	end function funcFGaussian

	!>
	!! This is neccesary only for FourierTransform3D_test()
	!!
	function funcRectangular( x, y, z ) result( output )
		real(8), intent(in) :: x, y, z
		complex(8) :: output

		real(8) :: a1, a2, a3

		a1 = 0.5_8
		a2 = 1.0_8
		a3 = 1.5_8

		output = Math_ubox( a1*x )*Math_ubox( a2*y )*Math_ubox( a3*z )
	end function funcRectangular

	!>
	!! This is neccesary only for FourierTransform3D_test()
	!!
	function FfuncRectangular( w1, w2, w3 ) result( output )
		real(8), intent(in) :: w1, w2, w3
		complex(8) :: output

		real(8) :: a1, a2, a3

		a1 = 0.5_8
		a2 = 1.0_8
		a3 = 1.5_8

		output = Math_nsinc( w1/(2.0_8*Math_PI*a1) ) &
					*Math_nsinc( w2/(2.0_8*Math_PI*a2) ) &
					*Math_nsinc( w3/(2.0_8*Math_PI*a3) )&
					/sqrt(2.0_8*Math_PI)**3/a1/a2/a3
	end function FfuncRectangular

	!>
	!! @bief test
	!!
	subroutine FourierTransform3D_test()
		type(Grid3D) :: xyzGrid, omegaGrid
		type(CNFunction3D) :: funcA, dFuncA, fftFuncA, fftDFuncA
		type(CNFunction3D) :: funcB, dFuncB, fftFuncB, fftDFuncB
		type(CNFunction3D) :: funcAB, dFuncAB, fftFuncAB, fftDFuncAB
		type(RNFunction3D) :: aSpectrum, pSpectrum
		type(FourierTransform3D) :: fft
		real(8) :: exactValue
		real(8) :: value
		integer :: i, j
		real(8), allocatable :: array(:,:,:)
		complex(8), allocatable :: cArray(:,:,:)
		integer(8) :: planF, planB
		character :: cBuffer

		write(*,*) "----------------------------------"
		write(*,*) " Verifing omega Grid constructors "
		write(*,*) "----------------------------------"

		xyzGrid = FourierTransform3D_omegaGridFromData( [10,11,12], [0.1_8,0.2_8,0.3_8], FourierTransform_NORDER )
		call xyzGrid.show()
		call xyzGrid.save()

		xyzGrid = FourierTransform3D_omegaGridFromData( [10,11,12], [0.1_8,0.2_8,0.3_8], FourierTransform_SORDER )
		call xyzGrid.show()
		call xyzGrid.save()

		write(*,*) "-------------------------------"
		write(*,*) " Verifing xy Grid constructors "
		write(*,*) "-------------------------------"

		xyzGrid = FourierTransform3D_xyzGridFromData( [10,11,12], [0.1_8,0.2_8,0.3_8], FourierTransform_NORDER )
		call xyzGrid.show()
		call xyzGrid.save()

		xyzGrid = FourierTransform3D_xyzGridFromData( [10,11,12], [0.1_8,0.2_8,0.3_8], FourierTransform_SORDER )
		call xyzGrid.show()
		call xyzGrid.save()

		return
		call GOptions_doYouWantToContinue()

! 		write(*,*) "-------------------------------------------"
! 		write(*,*) " FourierTransform3D of a gaussian function "
! 		write(*,*) "-------------------------------------------"
!
! 		call xyzGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyzGrid, funcRectangular )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		funcB = FourierTransform3D_fft( funcA )
! 		write(*,"(A)") "exact (.Ffunc) = "
! 		call funcB.show()
! 		call funcB.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		call xyzGrid.init( [-54.677675_8,-67.241507_8], [55.920349_8,68.486720_8], size=[90,110] )
! 		call funcB.init( xyzGrid, FfuncRectangular )
! ! 		funcB = FourierTransform3D_nft( funcA )
! 		write(*,"(A)") "exact (.Fexact) = "
! 		call funcB.show()
! 		call funcB.save( ".Fexact", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Fexact\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Fexact\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .Ffunc .Fexact" )

! 		write(*,*) "-----------------------------"
! 		write(*,*) " iFourierTransform3D of a gaussian function"
! 		write(*,*) "-----------------------------"
!
! 		call xyzGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyzGrid, funcRectangular )
! 		funcA = FourierTransform3D_nft( funcA )
! 		write(*,"(A)") "input (.Ffunc) = "
! 		call funcA.show()
! 		call funcA.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform3D (.func) = "
! 		funcB = funcA
! 		funcB = FourierTransform3D_ifft( funcB )
! 		call funcB.show()
! 		call funcB.save( ".func", format=BLKS_FORMAT )
!
! 		funcB = FourierTransform3D_inft( funcA )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save( ".exact", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".exact\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".exact\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .Ffunc .func .exact" )
!
! 		write(*,*) "-------------------------------"
! 		write(*,*) " iFourierTransform3D( FourierTransform3D(func) ). CNFunction3D "
! 		write(*,*) "-------------------------------"
!
! 		call xyzGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyzGrid, funcRectangular )
!
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "FourierTransform3D (.Ffunc) = "
! 		funcB = FourierTransform3D_fft( funcA )
! 		call funcB.show()
! 		call funcB.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform3D (.iFFfunc) = "
! 		funcA = FourierTransform3D_ifft( funcB )
! 		call funcA.show()
! 		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )
!
! ! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! ! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l, \"//achar(34)//"\"//achar(34)//" u 1:2:4 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .Ffunc .iFFfunc" )

! 		write(*,*) "--------------------------------"
! 		write(*,*) " FourierTransform3D( iFourierTransform3D(Ffunc) ). CNFunction3D "
! 		write(*,*) "--------------------------------"
!
! 		call xyzGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyzGrid, funcRectangular )
! 		funcA = FourierTransform3D_nft( funcA )
!
! 		write(*,"(A)") "input (.Ffunc) = "
! 		call funcA.show()
! 		call funcA.save( ".Ffunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "iFourierTransform3D (.iFfunc) = "
! 		funcA = FourierTransform3D_ifft( funcA )
! 		call funcA.show()
! 		call funcA.save( ".iFfunc", format=BLKS_FORMAT )
!
! 		write(*,"(A)") "FourierTransform3D (.FiFfunc) = "
! 		funcA = FourierTransform3D_fft( funcA )
! 		call funcA.show()
! 		call funcA.save( ".FiFfunc", format=BLKS_FORMAT )
!
! 		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".FiFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .Ffunc .iFfunc .FiFfunc" )

		write(*,*) "-----------------------------------------------------"
		write(*,*) " Verifing FourierTransform3D CNFunction3D with plans "
		write(*,*) "-----------------------------------------------------"

		call xyzGrid.init( [-2.5_8,-2.5_8,-2.5_8], [2.5_8,2.5_8,2.5_8], size=[90,110,200] )
		call funcA.init( xyzGrid, funcRectangular )
		write(*,"(A)") "input (.func) = "
		call funcA.show()
		call funcA.save( "func.cube", format=AUTO_FORMAT )

		planF = FourierTransform3D_plan( funcA, FourierTransform_FORWARD )
		planB = FourierTransform3D_plan( funcA, FourierTransform_BACKWARD )

		write(*,"(A)") "FourierTransform3D (.Ffunc) = "
		call FourierTransform3D_execute( planF )
		funcA.xyzGrid = FourierTransform3D_omegaGrid( funcA.xyzGrid, order=FourierTransform_SORDER )
! 		call FourierTransform3D_phase( funcA )
		call FourierTransform3D_shift( funcA )
		call funcA.show()
! 		call funcA.save( ".Ffunc", format=BLKS_FORMAT )
		call funcA.save( "Ffunc.cube", format=AUTO_FORMAT )
		call funcA.save( "Ffunc.n3df", format=AUTO_FORMAT )
		stop
		write(*,"(A)") "iFourierTransform3D (.iFFfunc) = "
		call FourierTransform3D_ishift( funcA )
		call FourierTransform3D_phase( funcA )
		call FourierTransform3D_execute( planB )
		funcA.xyzGrid = FourierTransform3D_xyzGrid( funcA.xyzGrid, order=FourierTransform_NORDER )
		funcA = funcA/real( funcA.nPoints(1)*funcA.nPoints(2), 8 )
		call funcA.show()
		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )

		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call GOptions_doYouWantToContinue()
		call system( "rm .func .Ffunc .iFFfunc" )

		call FourierTransform3D_destroyPlan( planF )
		call FourierTransform3D_destroyPlan( planB )

! 		write(*,*) "------------------------------------------"
! 		write(*,*) " iFourierTransform3D( FourierTransform3D(func) ). CNFunction3D with plans"
! 		write(*,*) "------------------------------------------"
!
! 		call xyzGrid.init( [-2.5_8,-2.5_8], [2.5_8,2.5_8], size=[90,110] )
! 		call funcA.init( xyzGrid, funcRectangular )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save( ".func", format=BLKS_FORMAT )
!
! 		planF = FourierTransform3D_plan( funcA, FourierTransform_FORWARD )
! 		planB = FourierTransform3D_plan( funcA, FourierTransform_BACKWARD )
!
! 		call FourierTransform3D_execute( planF )
! 		call FourierTransform3D_execute( planB )
! 		funcA = funcA/real( funcA.nPoints(1)*funcA.nPoints(2), 8 )
!
! 		call funcA.show()
! 		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )
!
! 		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .iFFfunc" )
!
! 		call FourierTransform3D_destroyPlan( planF )
! 		call FourierTransform3D_destroyPlan( planB )

		write(*,*) "-----------------------------------------"
		write(*,*) " Verifing FourierTransform3D CNFunction3D oriented object"
		write(*,*) "-----------------------------------------"

		call xyzGrid.init( [-2.5_8,-2.5_8,-2.5_8], [2.5_8,2.5_8,2.5_8], size=[90,110,130] )
		call funcA.init( xyzGrid, funcRectangular )
		write(*,"(A)") "input (.func) = "
		call funcA.show()
		call funcA.save( ".func", format=BLKS_FORMAT )

		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )

		call fft.execute( FourierTransform_FORWARD, sync=.true., shift=.true. )
		write(*,"(A)") "FourierTransform3D (.Ffunc) = "
		call funcA.show()
		call funcA.save( ".Ffunc", format=BLKS_FORMAT )

		call fft.execute( FourierTransform_BACKWARD, sync=.true., shift=.true. )
		write(*,"(A)") "iFourierTransform3D (.iFFfunc) = "
		call funcA.show()
		call funcA.save( ".iFFfunc", format=BLKS_FORMAT )

		call system( "echo splot \"//achar(34)//".func\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".Ffunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call system( "echo splot \"//achar(34)//".iFFfunc\"//achar(34)//" u 1:2:3 w l | gnuplot -p" )
		call GOptions_doYouWantToContinue()
		call system( "rm .func .Ffunc .iFFfunc" )

! 		write(*,*) "--------------------------------------"
! 		write(*,*) " Second derivative via FourierTransform3D with plans"
! 		write(*,*) "--------------------------------------"
!
! 		call xyzGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		omegaGrid = FourierTransform3D_omegaGrid( xyzGrid )
! 		call funcA.init( xyzGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		planF = FourierTransform3D_plan( funcA, FourierTransform3D_FORWARD )
! 		planB = FourierTransform3D_plan( funcA, FourierTransform3D_BACKWARD )
!
! 		call FourierTransform3D_execute( planF )
!
! 		funcA.yArray = ( Math_I*fft.omega )**2*funcA.yArray
!
! 		write(*,"(A)") "iFourierTransform3D (.dfunc) = "
! 		call FourierTransform3D_execute( planB )
! 		funcA = funcA/real( funcA.nPoints(), 8 )
! 		call funcA.show()
! 		call funcA.save(".dfunc")
!
! 		call funcB.init( xyzGrid, d2funcTest )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save(".exact")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".dfunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".exact\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .dfunc .exact" )
!
! 		call FourierTransform3D_destroyPlan( planF )
! 		call FourierTransform3D_destroyPlan( planB )
!
! 		write(*,*) "------------------------------------------------------"
! 		write(*,*) " Second derivative via FourierTransform3D CNFunction3D oriented object"
! 		write(*,*) "------------------------------------------------------"
!
! 		call xyzGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyzGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform3D_FORWARD )
!
! 		funcA.yArray = ( Math_I*fft.omega )**2*funcA.yArray
!
! 		call fft.execute( FourierTransform3D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform3D (.dfunc) = "
! 		call funcA.show()
! 		call funcA.save(".dfunc")
!
! 		call funcB.init( xyzGrid, d2funcTest )
! 		write(*,"(A)") "exact (.exact) = "
! 		call funcB.show()
! 		call funcB.save(".exact")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".dfunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".exact\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .dfunc .exact" )
!
! 		write(*,*) "----------"
! 		write(*,*) " Spectrum "
! 		write(*,*) "----------"
!
! ! 		call xyzGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call xyzGrid.init( -15.0_8, 15.0_8, 1001 )
! 		call funcA.init( xyzGrid, funcTest )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		aSpectrum = FourierTransform3D_powerSpectrum( funcA )
!
! 		write(*,"(A)") "aspec (.asfunc) = "
! 		call aSpectrum.show()
! 		call aSpectrum.save(".asfunc")
!
! 		pSpectrum = FourierTransform3D_phaseSpectrum( funcA )
!
! 		write(*,"(A)") "pspec (.psfunc) = "
! 		call pSpectrum.show()
! 		call pSpectrum.save(".psfunc")
!
! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! 		call system( "echo plot \"//achar(34)//".asfunc\"//achar(34)//" u 1:2 w l lw 1.5 | gnuplot -p" )
! 		call system( "echo plot \"//achar(34)//".psfunc\"//achar(34)//" u 1:2 w l lw 1.5 | gnuplot -p" )
! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .asfunc .psfunc" )
!
! 		write(*,*) "--------------------------------------------------------"
! 		write(*,*) " Filtering by amplitude. FourierTransform3D CNFunction3D oriented object"
! 		write(*,*) "--------------------------------------------------------"
!
! 		call xyzGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyzGrid, funcTestWithNoise )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform3D_FORWARD )
!
! 		where( abs( funcA.yArray ) <= 20.0_8 ) funcA.yArray = 0.0_8
!
! 		call fft.execute( FourierTransform3D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform3D (.ffunc) = "
! 		call funcA.show()
! 		call funcA.save(".ffunc")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".ffunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .ffunc" )
!
! 		write(*,*) "--------------------------------------------------------"
! 		write(*,*) " Filtering by frequency. FourierTransform3D CNFunction3D oriented object"
! 		write(*,*) "--------------------------------------------------------"
!
! 		call xyzGrid.init( -3.0_8*Math_PI, 3.0_8*Math_PI, 1001 )
! 		call funcA.init( xyzGrid, funcTestWithNoise )
! 		write(*,"(A)") "input (.func) = "
! 		call funcA.show()
! 		call funcA.save(".func")
!
! 		call fft.init( funcA, FourierTransform_SPATIAL_DOMAIN )
!
! 		call fft.execute( FourierTransform3D_FORWARD )
!
! 		do i=1,funcA.nPoints()
! 			if( abs( fft.omega(i) ) > 10.0_8 ) then
! 				funcA.yArray(i) = 0.0_8
! 			end if
! 		end do
!
! 		call fft.execute( FourierTransform3D_BACKWARD )
!
! 		write(*,"(A)") "iFourierTransform3D (.ffunc) = "
! 		call funcA.show()
! 		call funcA.save(".ffunc")
!
! ! 		call system( "echo plot \"//achar(34)//".func\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call system( "echo plot \"//achar(34)//".ffunc\"//achar(34)//" u 1:2 w l lw 1.5, \"//achar(34)//"\"//achar(34)//" u 1:3 w l lw 1.5 | gnuplot -p" )
! ! 		call GOptions_doYouWantToContinue()
! 		call system( "rm .func .ffunc" )

	end subroutine FourierTransform3D_test

end module FourierTransform3D_