!Implemented by Anant Dixit (October, 2014)
program animated_pendulum
implicit none
double precision, parameter :: pi = 4.0D0*atan(1.0D0), l = 1.0D-1, dt = 1.0D-2, g = 9.8D0
integer :: io
double precision :: s_ang, c_ang, p_ang, n_ang

write(*,*) 'Enter starting angle (in degrees):'
do
  read(*,*,iostat=io) s_ang
  if(io.ne.0 .or. s_ang.lt.-90.0D0 .or. s_ang.gt.90.0D0) then
    write(*,*) 'Please enter an angle between 90 and -90 degrees:'
  else
    exit
  end if
end do
call system('clear')

c_ang = s_ang*pi/180.0D0
p_ang = c_ang

call display(c_ang)
do
  call next_time_step(c_ang,p_ang,g,l,dt,n_ang)
  if(abs(c_ang-p_ang).ge.0.05D0) then
    call system('clear')
    call display(c_ang)
  end if
end do
end program

subroutine next_time_step(c_ang,p_ang,g,l,dt,n_ang)
double precision :: c_ang, p_ang, g, l, dt, n_ang
n_ang = (-g*sin(c_ang)/l)*2.0D0*dt**2 + 2.0D0*c_ang - p_ang
p_ang = c_ang
c_ang = n_ang
end subroutine

subroutine display(c_ang)
double precision :: c_ang
character (len=*), parameter :: cfmt = '(A1)'
double precision :: rx, ry
integer :: x, y, i, j
rx = 45.0D0*sin(c_ang)
ry = 22.5D0*cos(c_ang)
x = int(rx)+51
y = int(ry)+2
do i = 1,32
  do j = 1,100
    if(i.eq.y .and. j.eq.x) then
      write(*,cfmt,advance='no') 'O'
    else if(i.eq.y .and. (j.eq.(x-1).or.j.eq.(x+1))) then
      write(*,cfmt,advance='no') 'G'
    else if(j.eq.x .and. (i.eq.(y-1).or.i.eq.(y+1))) then
      write(*,cfmt,advance='no') 'G'
    else if(i.eq.y .and. (j.eq.(x-2).or.j.eq.(x+2))) then
      write(*,cfmt,advance='no') '#'
    else if(j.eq.x .and. (i.eq.(y-2).or.i.eq.(y+2))) then
      write(*,cfmt,advance='no') 'G'
    else if((i.eq.(y+1).and.j.eq.(x+1)) .or. (i.eq.(y-1).and.j.eq.(x-1))) then
      write(*,cfmt,advance='no') '#'
    else if((i.eq.(y+1).and.j.eq.(x-1)) .or. (i.eq.(y-1).and.j.eq.(x+1))) then
      write(*,cfmt,advance='no') '#'
    else if(j.eq.50) then
      write(*,cfmt,advance='no') '|'
    else if(i.eq.2) then
      write(*,cfmt,advance='no') '-'
    else
      write(*,cfmt,advance='no') ' '
    end if
  end do
  write(*,*)
end do
end subroutine


subroutine sim(error, mpar, user_data, evec)
!DEC$ ATTRIBUTES DLLEXPORT :: sim
implicit none
    ! Main user simulation subroutine
    double precision, intent(out)               :: error            ! Error to be minimized
    double precision, intent(in)                :: mpar(:)          ! Material parameters
    double precision, allocatable, intent(in)   :: user_data(:)     ! Array of user double data
    double precision, allocatable, optional     :: evec(:)          ! Optional array of errors for each time instance, calculate if present

    error = user_data(1)*mpar(1) + user_data(2)*mpar(2)*mpar(4) - user_data(3)*mpar(2)**2
    !error = mpar(1) + mpar(2)*mpar(4) - mpar(2)**2
    if (present(evec)) then
        if (.not.allocated(evec)) allocate(evec(3))
        evec(1) = mpar(1)
        evec(2) = mpar(2)*mpar(4)
        evec(3) = mpar(2)**2
    endif

end subroutine

subroutine sim_input(inpfile, user_data)
!DEC$ ATTRIBUTES DLLEXPORT :: sim_input
implicit none
    character(len=*), intent(in)                :: inpfile      ! Filename of settings file to read from
    double precision, allocatable, intent(out)  :: user_data(:) ! Pointer to user settings to be used by the user_sim subroutine

    allocate(user_data(3))
    user_data = [1.d0, -3.d0, -4.d0]

end subroutine


C    @(#)gettrf.f	20.3 2/13/96
        subroutine gettrf (jt, lt, nt, senstl, senstt, pout, dpovld,
     1                     comp, tx)
C
C       This subroutine computes compensation COMP and transfer TX in
C       three modes:
C
C       1. JT = 0: No outage occurs, i.e., compute the base case transfe
C       2. LT = 0: No overload occurs, i.e., compute the compensation
C                  COMP
C       3.         Normal: compute the compensation COMP and the transfe
C                  TX to alleviate overload DPOVLD.
C
C       Input parameters:
C
C         JT - outage index
C         LT - overload index
C         NT - transfer index
C         SENSTL(2,*) - the Sensitivities G(x)**-1 * G(u) for outages
C         SENSTF(*) - the Sensitivities G(x)**-1 * G(t) for transfer
C         POUT - the base line flow of the outaged line
C         DPOVLD - the required power excursion in the monitored line
C
C       Output parameters:
C
C         COMP - the outage compensation to simulate outage Pout
C         TX - the transfer to alleviate the overload dPovld
C
C       The general form is
C
C        | L(l) - L(x)*SENSTL    -L(X)*SENSTT    || dl |   | -L(0)  |
C        |                                       ||    | = |        |
C        |      - F(x)*SENSTL    -F(x)*SENSTT    || dt |   | -dF(0) |
C
C       where dL = COMP and dt = TX.
C

      include 'ipfinc/ecvar.inc'
c	Global variables used:
c		idswb
      include 'ipfinc/lfiles.inc'
c	Global variables used:
c		dbug
      include 'ipfinc/transf.inc'
c	Global variables used:
c		fdata, ldata

        double precision senstl(2,*)
c
        real senstt(*)
c
        if (jt .eq. 0) then
C
C          Determine transfer without outage (base overload)
C
           comp = 0.0
           if (lt .eq. 0) then
              tx = 0.0
           else
              k1 = kfdata(1,lt)
              k2 = kfdata(2,lt)
              x = -fdata(11,lt)*senstt(k1) - fdata(13,lt)*senstt(k2)
              if (x .eq. 0.0) then
                 tx = sign (1.0e10,-dpovld)
              else
                 tx = -dpovld / x
              endif
           endif

        else if (nt .eq. 0) then
C
C          Determine compensation without transfer (outage without
C          corrective action)
C
           tx = 0.0
           if (jt .eq. 0) then
              comp = 0.0
           else
              k1 = kldata(1,jt)
              k2 = kldata(2,jt)
              x = 1.0 - ldata(11,jt) * senstl(1,k1) -
     1                  ldata(13,jt) * senstl(1,k2)
              if (x .eq. 0.0) then
                 comp = sign (1.0e10,-pout)
              else
                 comp = -pout / x
              endif
           endif
        else if (lt .eq. 0) then
           comp = 0.0
           tx = 0.0
        else
C
C          Determine compensation and transfer simultaneously
C
           k1 = kldata(1,jt)
           k2 = kldata(2,jt)
           a11 = 1.0 - ldata(11,jt) * senstl(1,k1)
     1               - ldata(13,jt) * senstl(1,k2)
           a12 = -ldata(11,jt) * senstt(k1) - ldata(13,jt) * senstt(k2)

           k1 = kfdata(1,lt)
           k2 = kfdata(2,lt)
           a21 = -fdata(11,lt) * senstl(1,k1)
     1          - fdata(13,lt) * senstl(1,k2)
           a22 = -fdata(11,lt) * senstt(k1) - fdata(13,lt) * senstt(k2)

           denom = a11 * a22 - a21 * a12
           if (abs (denom) .le. 1.0e-6) then
              comp = sign (1.0e10,-pout)
              tx = sign (1.0e10,-dpovld)
           else
              comp = (a22 * (-pout) - a12 * (-dpovld)) / denom
              tx = (-a21 * (-pout) + a11 * (-dpovld)) / denom
           endif
        endif

        if (idswb .gt. 0) then
            write (dbug,100) jt, lt, nt, pout, dpovld, comp, tx
  100       format (' GETTRF/ JT,LT,NT,POUT,DPOVLD,COMP,TX ',
     1         3i5,4e12.5)
        endif

        return
        end


!########################################################
!     Program  : HMMPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Hubbard model using DMFT away from half-filling
! with modified itertive perturbation scheme (MPT)
!     AUTHORS  : Adriano Amaricci
!########################################################
module COMMON
  USE BROYDEN
  implicit none
  real(8)                :: xmu0,n,n0
  real(8),allocatable    :: wr(:)
  complex(8),allocatable :: sigma(:),fg(:),fg0(:),gamma(:)
end module COMMON

function funcv(x)
  USE COMMON
  USE TOOLS
  USE COMMON_VARS
  implicit none
  real(8),dimension(:),intent(in)  ::  x
  real(8),dimension(size(x))       ::  funcv
  xmu0=x(1)
  !Hartree corrected WF is:
  !\tilde{\calG0}^-1 = \calG0^-1 +xmu -xmu0 -U*n
  fg0 = one/(one/gamma +xmu-xmu0-U*(n-0.5d0))
  n0=sum(fermi(wr,beta)*aimag(fg0))/sum(aimag(fg0))
  funcv(1)=n-n0
  write(*,"(3(f13.9))")n,n0,xmu0
end function funcv

program hmmpt_2dsquare
  USE DMFT_IPT
  USE COMMON
  USE SQUARE_LATTICE
  USE IOTOOLS
  implicit none
  integer    :: i,Lk
  real(8)    :: x(1),z
  logical    :: check,converged
  complex(8) :: zeta

  real(8) :: nread,nerror,ndelta
  integer :: nindex=0

  real(8),allocatable    :: wt(:),epsik(:),wm(:)
  complex(8),allocatable :: sold(:)
  type(matsubara_gf)     :: fgm
  include "revision.inc"
  call version(revision)

  call read_input("inputIPT.in")
  call parse_cmd_variable(nread,"NREAD",default=0.d0)
  call parse_cmd_variable(nerror,"NERROR",default=1.d-4)
  call parse_cmd_variable(ndelta,"NDELTA",default=0.1d0)

  allocate(fg(L),sigma(L),fg0(L),gamma(L))
  allocate(sold(L))
  allocate(wr(L))

  !Build frequency array
  wr=linspace(-wmax,wmax,L,mesh=fmesh)

  !build square lattice structure:
  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  n=0.5d0 ; sigma=u*(n-0.5d0) ; xmu0=xmu
  iloop=0 ; converged=.false. ; sold=zero
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5,1x)")"DMFT-loop",iloop
     do i=1,L
        zeta  = cmplx(wr(i),eps) + xmu - sigma(i)
        fg(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     n=sum(fermi(wr,beta)*aimag(fg))/sum(aimag(fg))

     !Get the regular Weiss Field: \Gamma(w+xmu)
     gamma= one/(one/fg + sigma) !gamma= cmplx(wr,eps)+xmu-sigma-one/fg

     !Fix the xmu0 w/ condition n0=n
     x(1)=xmu
     call broydn(x,check)
     xmu0=x(1)

     sigma= solve_mpt_sopt(fg0,wr,n,n0,xmu0)
     sigma=weight*sigma + (1.d0-weight)*sold
     sold=sigma
     converged=check_convergence(sigma,eps_error,nsuccess,nloop)
     call splot("nVSiloop.ipt",iloop,n,append=TT)
     if(nread/=0.d0)call search_mu(converged)
  enddo
  call close_file("nVSiloop.ipt")
  call splot("DOS.ipt",wr,-aimag(fg)/pi,append=printf)
  call splot("G_realw.ipt",wr,fg,append=printf)
  call splot("G0_realw.ipt",wr,fg0,append=printf)
  call splot("Sigma_realw.ipt",wr,sigma,append=printf)

  L=max(8192,8*L)
  call allocate_gf(fgm,L)
  allocate(wm(L))
  wm = pi/beta*real(2*arange(1,L)-1,8)

  call get_matsubara_gf_from_dos(wr,fg,fgm%iw,beta)
  call splot("G_iw.ipt",wm,fgm%iw,append=printf)
  fgm=zero
  call get_matsubara_gf_from_dos(wr,sigma,fgm%iw,beta)
  call splot("Sigma_iw.ipt",wm,fgm%iw,append=printf)
  z=1.d0 - dimag(fgm%iw(1))/wm(1);z=1.d0/z
  call splot("n.z.u.xmu.ipt",n,z,u,xmu,append=printf)

contains

  subroutine search_mu(convergence)
    real(8)               :: naverage
    logical,intent(inout) :: convergence
    real(8)               :: ndelta1
    integer               :: nindex1
    naverage=2.d0*n
    nindex1=nindex
    ndelta1=ndelta
    if((naverage >= nread+nerror))then
       nindex=-1
    elseif(naverage <= nread-nerror)then
       nindex=1
    else
       nindex=0
    endif
    if(nindex1+nindex==0)then !avoid loop forth and back
       ndelta=ndelta1/2.d0 !decreasing the step
    else
       ndelta=ndelta1
    endif
    xmu=xmu+real(nindex,8)*ndelta
    write(*,"(A,f15.12,A,f15.12,A,f20.17,A,f15.12)")" n=",naverage," /",nread,&
         "| shift=",nindex*ndelta,"| xmu=",xmu
    write(*,"(A,f15.12)")"dn=",abs(naverage-nread)
    print*,""
    if(abs(naverage-nread)>nerror)convergence=.false.
    call splot("muVSiter.ipt",iloop,xmu,abs(naverage-nread),append=.true.)
  end subroutine search_mu

end program hmmpt_2dsquare


c
c -------------------------------------------------------------
c
      subroutine vrm_conserved(qr,ql,rx,ixmin,ixmax,iflip,msize)
      implicit double precision (a-h,o-z)
      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
      parameter ( m1size = 4033)
      dimension qr(msize,4),ql(msize,4)
      dimension rx(msize,4), rlx(4), rrx(4), stateR(4), stateL(4)
      dimension rhor(m1size),ur(m1size),pr(m1size),utr(m1size)
      dimension rhol(m1size),ul(m1size),pl(m1size),utl(m1size)

      data      itno/2/, small/1.d-6/
c
c
c     # HLL vector Riemann solver
c     # Given primitive variables, compute
c     # conserved variables at interface by solving riemann problem
c     # only solve neighboring vertical interfaces
c
c      iflip = 1 indicates the normal velocity is in
c                qr(k,2) and the tangential in qr(k,3)
c            = 0 indicates the reverse.
c   done so a single riemann solver can be used for both columns and rows.
c
      if (ixmax .gt. m1size) then
         write(6,*)" need to increase m1size in vrm to ", ixmax
         stop
      endif

      inorm = 3 - iflip
      itan  = 2 + iflip

      do 10 k = ixmin, ixmax
         rhor(k) = qr(k,1)
         ur(k)   = qr(k,inorm)/qr(k,1)
         utr(k)  = qr(k,itan)/qr(k,1)
         pr(k)   = (gamma-1.d0)*(qr(k,4)
     .                           -0.5d0*rhor(k)*(ur(k)**2+utr(k)**2) )
         rhol(k) = ql(k,1)
         ul(k)   = ql(k,inorm)/ql(k,1)
         utl(k)  = ql(k,itan)/ql(k,1)
         pl(k)   = (gamma-1.d0)*(ql(k,4)
     .                           -0.5d0*rhol(k)*(ul(k)**2+utl(k)**2) )
  10     continue
c
      do 20 k = ixmin, ixmax
        aL  = dsqrt(gamma*pl(k)/rhol(k))
        aR  = dsqrt(gamma*pr(k)/rhor(k))

c       sL = ul(k) - aL;
c       sR = ur(k) + aR;
        sL = min((ul(k) - aL), (ur(k) - aR)) ! fancier option
        sR = max((ul(k) + aL), (ur(k) + aR))

        if (0. .lt. sL) then   ! use left flux

         rx(k,1)     = rhol(k)*ul(k)
         rx(k,inorm) = rhol(k)*ul(k)*ul(k) + pl(k)
         rx(k,itan)  = rhol(k)*ul(k)*utl(k)
         etot        = .5*rhol(k)*(ul(k)*ul(k)+utl(k)*utl(k)) +
     .                  pl(k)/gamma1
         rx(k,4)     = ul(k)*(etot + pl(k))

        else if (0. .gt. sR) then   ! flux is right flux

         rx(k,1)     = rhor(k)*ur(k)
         rx(k,inorm) = rhor(k)*ur(k)*ur(k) + pr(k)
         rx(k,itan)  = rhor(k)*ur(k)*utr(k)
         etot        = .5*rhor(k)*(ur(k)*ur(k)+utr(k)*utr(k)) +
     .                  pr(k)/gamma1
         rx(k,4)     = ur(k)*(etot + pr(k))

        else
        ! middle flux
         rlx(1)     = rhol(k)*ul(k)
         rlx(inorm) = rhol(k)*ul(k)*ul(k) + pl(k)
         rlx(itan)  = rhol(k)*ul(k)*utl(k)
         etotl        = .5*rhol(k)*(ul(k)*ul(k)+utl(k)*utl(k)) +
     .                  pl(k)/gamma1
         rlx(4)     = ul(k)*(etotl + pl(k))

         rrx(1)     = rhor(k)*ur(k)
         rrx(inorm) = rhor(k)*ur(k)*ur(k) + pr(k)
         rrx(itan)  = rhor(k)*ur(k)*utr(k)
         etotr        = .5*rhor(k)*(ur(k)*ur(k)+utr(k)*utr(k)) +
     .                  pr(k)/gamma1
         rrx(4)     = ur(k)*(etotr + pr(k))

         stateL(1)     = ql(k,1)
         stateL(inorm) = ql(k,inorm)
         stateL(itan)  = ql(k,itan)
         stateL(4)     = ql(k,4)

         stateR(1)     = qr(k,1)
         stateR(inorm) = qr(k,inorm)
         stateR(itan)  = qr(k,itan)
         stateR(4)     = qr(k,4)

         rx(k,:)=(sR*rlx(:)-sL*rrx(:)
     .                       +sL*sR*( stateR(:)-stateL(:) ) )/ (sR-sL)
        endif
 20   continue

c
       return
       end


!This samples illustrates a basic use of cuFFTMp using the built-in, optimized, data distributions.
!
!  It assumes the CPU data is initially distributed according to CUFFT_XT_FORMAT_INPLACE, a.k.a. X-Slabs.
!  Given a global array of size X!  Y!  Z, every MPI rank owns approximately (X / ngpus)!  Y*Z entries.
!  More precisely,
!  - The first (ngpus % X) MPI rank each own (X / ngpus + 1) planes of size Y * Z,
!  - The remaining MPI rank each own (X / ngpus) planes of size Y*Z
!
!  The CPU data is then copied on GPU and a forward transform is applied.
!
!  After that transform, GPU data is distributed according to CUFFT_XT_FORMAT_INPLACE_SHUFFLED, a.k.a. Y-Slabs.
!  Given a global array of size X * Y * Z, every MPI rank owns approximately X * (Y / ngpus) * Z entries.
!  More precisely,
!  - The first (ngpus % Y) MPI rank each own (Y / ngpus + 1) planes of size X * Z,
!  - The remaining MPI rank each own (Y / ngpus) planes of size X * Z
!
!  A scaling kerel is applied, on the distributed GPU data (distributed according to CUFFT_XT_FORMAT_INPLACE)
!  This kernel prints some elements to illustrate the CUFFT_XT_FORMAT_INPLACE_SHUFFLED data distribution and
!  normalize entries by (nx * ny * nz)
!
!  Finally, a backward transform is applied.
!  After this, data is again distributed according to CUFFT_XT_FORMAT_INPLACE, same as the input data.
!
!  Data is finally copied back to CPU and compared to the input data. They should be almost identical.

program cufftmp_c2c
    use iso_c_binding
    use cudafor
    use cufftXt
    use cufft
    use openacc
    use mpi
    implicit none

    integer :: size, rank, ndevices, ierr
    integer :: nx, ny, nz ! nx slowest
    integer :: i, j, k
    integer :: my_nx, my_ny, my_nz, ranks_cutoff, whichgpu(1)
    complex, dimension(:, :, :), allocatable :: u, ref, u_permuted
    real :: max_norm, max_diff

    ! cufft stuff
    integer :: plan
    integer(c_size_t) :: worksize(1)
    type(cudaLibXtDesc), pointer :: u_desc
    type(cudaXtDesc), pointer    :: u_descptr
#ifdef ACC
    complex, pointer             :: u_dptr(:,:,:)
    type(c_ptr)                  :: tmpcptr
#else
    complex, pointer, device     :: u_dptr(:,:,:)
#endif
    integer :: local_cshape(3), local_permuted_cshape(3)

    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD,size,ierr)
    call mpi_comm_rank(MPI_COMM_WORLD,rank,ierr)

    call checkCuda(cudaGetDeviceCount(ndevices))
    call checkCuda(cudaSetDevice(mod(rank, ndevices)))
    whichgpu(1) = mod(rank, ndevices)

    print*,"Hello from rank ", rank, " gpu id", mod(rank, ndevices), "size", size

    nx = 256
    ny = nx
    nz = nx

    ! We start with X-Slabs
    ! Ranks 0 ... (nx % size - 1) have 1 more element in the X dimension
    ! and every rank own all elements in the Y and Z dimensions.
    ranks_cutoff = mod(nx, size)
    my_nx = nx / size
    if (rank < ranks_cutoff) my_nx = my_nx + 1
    my_ny =  ny;
    my_nz =  nz;
    local_cshape = [nz, ny, my_nx]
    local_permuted_cshape = [nz, ny/size, nx]
    if (mod(ny, size) > 0) then
        print*," ny has to divide evenly by mpi_procs"
        call mpi_finalize(ierr)
    end if
    if (rank == 0) then
        write(*,*) "local_cshape          :", local_cshape(1), local_cshape(2), local_cshape(3)
        write(*,*) "local_permuted_cshape :", local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3)
    end if

    ! Generate local, distributed data
    allocate(u(local_cshape(1), local_cshape(2), local_cshape(3)))
    allocate(u_permuted(local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3)))
    allocate(ref(local_cshape(1), local_cshape(2), local_cshape(3)))
    call generate_random(local_cshape(1), local_cshape(2), local_cshape(3), u)
    ref = u
    u_permuted = (0.0,0.0)

    call checkNorm(local_cshape(1), local_cshape(2), local_cshape(3), u, max_norm)
    print*, "initial data on ", rank, " max_norm is ", max_norm

    call checkCufft(cufftCreate(plan))
    call checkCufft(cufftMpAttachComm(plan, CUFFT_COMM_MPI, MPI_COMM_WORLD), 'cufftMpAttachComm error')

    call checkCufft(cufftMakePlan3d(plan, nz, ny, nx, CUFFT_C2C, worksize), 'cufftMakePlan3d error')

    call checkCufft(cufftXtMalloc(plan, u_desc, CUFFT_XT_FORMAT_INPLACE), 'cufftXtMalloc error')
    call checkCufft(cufftXtMemcpy(plan, u_desc, u, CUFFT_COPY_HOST_TO_DEVICE), 'cufftXtMemcpy error')
    ! now reset u to make sure the check later is valid
    u = (0.0,0.0)

    !xxxxxxxxxxxxxxxxxxxxxxxxxx Forward
    call checkCufft(cufftXtExecDescriptor(plan, u_desc, u_desc, CUFFT_FORWARD),'forward fft failed')

    ! in case we want to check the results after Forward
    call checkCufft(cufftXtMemcpy(plan, u_permuted, u_desc, CUFFT_COPY_DEVICE_TO_HOST), 'permuted D2H error')
    call checkNorm(local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3), u_permuted, max_norm)
    write(*,'(A18, I1, A14, F25.8)') "after C2C forward ", rank, " max_norm is ", max_norm

    ! Data is now distributed as Y-Slab. We need to scale the output
    call c_f_pointer(u_desc%descriptor, u_descptr)

#ifndef ACC
    call c_f_pointer(u_descptr%data(1), u_dptr, [local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3)])
    !$cuf kernel do (3)
    do k =1, local_permuted_cshape(3)
        do j = 1, local_permuted_cshape(2)
            do i = 1, local_permuted_cshape(1)
                u_dptr(i,j,k) = u_dptr(i,j,k) / real(nx*ny*nz)
            end do
        end do
    end do
    call checkCuda(cudaDeviceSynchronize())
#else
    tmpcptr = transfer(u_descptr%data(1), tmpcptr)
    call c_f_pointer(tmpcptr, u_dptr, [local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3)])

    call scalingData(local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3), u_dptr, real(nx*ny*nz))
#endif

    ! in case we want to check again after scaling
    call checkCufft(cufftXtMemcpy(plan, u_permuted, u_desc, CUFFT_COPY_DEVICE_TO_HOST), 'permuted D2H error')
    call checkNorm(local_permuted_cshape(1), local_permuted_cshape(2), local_permuted_cshape(3), u_permuted, max_norm)
    write(*,'(A18, I1, A14, F25.8)') "after scaling ", rank, " max_norm is ", max_norm

    !xxxxxxxxxxxxxxxxxxxxxxxxxxxx inverse
    call checkCufft(cufftXtExecDescriptor(plan, u_desc, u_desc, CUFFT_INVERSE), 'inverse fft failed')
    call checkCufft(cufftXtMemcpy(plan, u, u_desc, CUFFT_COPY_DEVICE_TO_HOST), 'D2H failed')
    call checkCufft(cufftXtFree(u_desc))
    call checkCufft(cufftDestroy(plan))

    call checkNormDiff(local_cshape(1), local_cshape(2), local_cshape(3), u, ref, max_norm, max_diff)
    write(*,'(A18, I1, A14, F25.8, A14, F15.8)') "after C2C inverse ", rank, " max_norm is ", max_norm, " max_diff is ", max_diff
    write(*,'(A25, I1, A14, F25.8)') "Relative Linf on rank ", rank, " is ", max_diff/max_norm

    call mpi_finalize(ierr)

    if(max_diff / max_norm > 1.5e-6) then
        print*, ">>>> FAILED on rank ", rank
        stop 1
    else
        print*, ">>>> PASSED on rank ", rank
    end if

contains
    subroutine checkCuda(istat, message)
        integer, intent(in)                   :: istat
        character(len=*),intent(in), optional :: message
        if (istat /= cudaSuccess) then
            write(*,"('Error code: ',I0, ': ')") istat
            write(*,*) cudaGetErrorString(istat)
            if(present(message)) write(*,*) message
            call mpi_finalize(ierr)
        endif
    end subroutine checkCuda

    subroutine checkCufft(istat, message)
        integer, intent(in)                   :: istat
        character(len=*),intent(in), optional :: message
        if (istat /= CUFFT_SUCCESS) then
            write(*,"('Error code: ',I0, ': ')") istat
            write(*,*) cudaGetErrorString(istat)
            if(present(message)) write(*,*) message
            call mpi_finalize(ierr)
        endif
    end subroutine checkCufft

    subroutine generate_random(nz, ny, nx, data)
        integer, intent(in) :: nx, ny, nz
        complex, dimension(nz, ny, nx), intent(out) :: data
        real :: rand(2)
        integer :: i,j,k
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    call random_number(rand)
                    data(i,j,k)%re = rand(1)
                    data(i,j,k)%im = rand(2)
                end do
            end do
        end do

    end subroutine generate_random

    subroutine checkNorm(nz, ny, nx, data, max_norm)
        integer, intent(in)  :: nx, ny, nz
        complex, dimension(nz, ny, nx), intent(in) :: data
        real :: max_norm, max_diff
        max_norm = 0
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    max_norm = max(max_norm, abs(data(i,j,k)%re))
                    max_norm = max(max_norm, abs(data(i,j,k)%im))
                end do
            end do
        end do
    end subroutine checkNorm

    subroutine checkNormDiff(nz, ny, nx, data, ref, max_norm, max_diff)
        integer, intent(in)  :: nx, ny, nz
        complex, dimension(nz, ny, nx), intent(in) :: data, ref
        real :: max_norm, max_diff
        max_norm = 0
        max_diff = 0
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    max_norm = max(max_norm, abs(data(i,j,k)%re))
                    max_norm = max(max_norm, abs(data(i,j,k)%im))
                    max_diff = max(max_diff, abs(ref(i,j,k)%re-data(i,j,k)%re))
                    max_diff = max(max_diff, abs(ref(i,j,k)%im-data(i,j,k)%im))
                end do
            end do
        end do
    end subroutine checkNormDiff

#ifdef ACC
    subroutine scalingData(nz, ny, nx, data, factor)
        integer, intent(in)  :: nx, ny, nz
        complex, dimension(nz, ny, nz) :: data
        !$acc declare deviceptr(data)
        real, intent(in)     :: factor

    !$acc parallel loop collapse(3)
        do k =1, nx
            do j = 1, ny
                do i = 1, nz
                    data(i, j, k) = data(i, j, k) / factor
                end do
            end do
        end do

    end subroutine scalingData
#endif

end program cufftmp_c2c