c
c     Numerical Analysis:
c     Mathematics of Scientific Computing
c     Third Edition
c     D.R. Kincaid & E.W. Cheney
c     Brooks/Cole Publ., 2002
c     Copyright (c) 1996
c
c     Section 5.3
c
c     Example of modified Gram-Schmidt algorithm
c
c
c     file: qrshif.f
c
      parameter (n=4,m=10)
      dimension a(n,n),q(n,n),r(n,n)
      data (a(1,j),j=1,n)/1.,2.,3.,4./
      data (a(2,j),j=1,n)/5.,6.,7.,8./
      data (a(3,j),j=1,n)/0.,9.,10.,11./
      data (a(4,j),j=1,n)/0.,0.,12.,13./
c
      print *
      print *,' Modified Gram-Schimdt example'
      print *,' Section 5.3, Kincaid-Cheney'
      print *
c
      do 4 k=1,m
         print *,' Matrix A'
         call prtmtx(n,a)
         z = a(n,n)
         do 2 i=1,n
            a(i,i)= a(i,i) - z
 2       continue
         call mgs(a,q,r,n,n)
         print *,' Matrix Q'
         call prtmtx(n,q)
         print *,' Matrix R'
         call prtmtx(n,r)
         call mult(n,r,q,a)
         do 3 i=1,n
            a(i,i)=a(i,i) + z
 3       continue
 4    continue
c
      stop
      end
c
      subroutine prtmtx(n,a)
c
c     print array a
c
      dimension a(n,n)
c
      do 2 i=1,n
         print 3,(a(i,j),j=1,n)
 2    continue
      print *
c
      return
 3    format(2x,4(e13.6,2x))
      end
c
      subroutine mgs(a,q,t,m,n)
c
c     modified Gram-Schimdt
c
      dimension a(m,n),q(m,n),t(n,n)
c
      do 3 j=1,n
         do 2 i=1,n
            t(i,j)=0.
 2       continue
         do 3 i=1,m
            q(i,j)=a(i,j)
 3    continue
      do 7 k=1,n
         z=0.
         do 4 i=1,m
            z=z+q(i,k)**2
 4       continue
         t(k,k)=sqrt(z)
         do 5 i=1,m
            q(i,k)=q(i,k)/t(k,k)
 5       continue
         do 7 j=k+1,n
            z=0.
            do 6 i=1,m
               z=z+q(i,j)*q(i,k)
 6          continue
            t(k,j)=z
            do 7 i=1,m
               q(i,j)=q(i,j)-t(k,j)*q(i,k)
 7     continue
c
      return
      end
c
      subroutine mult (n,a,b,c)
c
c     compute matrix product c=ab
c
      dimension a(n,n),b(n,n),c(n,n)
c
      do 3 i=1,n
         do 3 j=1,n
            x=0.0
            do 2 k=1,n
               x=x+a(i,k)*b(k,j)
 2          continue
 3    c(i,j)=x
c
      return
      end


subroutine SHMultiply(shout, sh1, lmax1, sh2, lmax2, precomp, norm, csphase)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will multiply two spherical harmonic fields which are expressed
!	up to maximum spherical harmonic degrees lmax1 and lmax2. The output spherical
!	harmonic coefficients will have a maximum spherical harmonic degree equal
!	to lmax1 + lmax2.
!
!	Calling Parameters:
!		IN
!			sh1		Spherical harmonic field with maximum spherical harmonic
!					degree lmax1.
!			sh2		Spherical harmonic field with maximun spherical harmonic
!					degree lmax2.
!			lmax1		Maximum spherical harmonic degree of sh1.
!			lmax2		Maximum spherical harmonic degree of sh2.
!		OUT
!			shout		Spherical harmonic expansion of spatial multiplication of
!					sh1 and sh2, with a maximum spherical harmonic degree of
!					lmax1 + lmax2.
!		OPTIONAL (IN)
!			precomp		If 1, the array plx will be precomputed when calling
!					the subroutine PreCompute. If 0 (default), then this array will
!					not be precomputed.
!			csphase:	1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!			norm:		Normalization to be used when calculating Legendre functions
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!
!	Dependencies:	PreCompute, MakeGridGLQ, SHExpandGLQ, CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek 2004
!	September 3, 2005. Modified to include the optional argument precomp which determines whether
!	the array plx will be precomputed in the subroutine PreCompute.
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PreCompute, MakeGridGLQ, SHExpandGLQ, CSPHASE_DEFAULT

	implicit none

	real*8, intent(out) ::	shout(:,:,:)
	real*8, intent(in) ::	sh1(:,:,:), sh2(:,:,:)
	integer, intent(in) ::	lmax1, lmax2
	integer, intent(in), optional ::	precomp, norm, csphase
	integer :: 	lmaxout, phase, mnorm, astat(3)
	real*8 ::	zero(lmax1+lmax2+1), w(lmax1+lmax2+1)
	real*8, allocatable :: 	grid1glq(:,:), grid2glq(:,:), plx(:,:)

	if (size(sh1(:,1,1)) < 2 .or. size(sh1(1,:,1)) < lmax1+1 .or. size(sh1(1,1,:)) < lmax1+1) then
		print*, "Error --- SHMultiply"
		print*, "SHI must be dimensioned as (2, LMAX1+1, LMAX1+1) where LMAX1 is", lmax1
		print*, "Input array is dimensioned ", size(sh1(:,1,1)),  size(sh1(1,:,1)), size(sh1(1,1,:))
		stop
	elseif (size(sh2(:,1,1)) < 2 .or. size(sh2(1,:,1)) < lmax2+1 .or. size(sh2(1,1,:)) < lmax2+1) then
		print*, "Error --- SHMultiply"
		print*, "SH2 must be dimensioned as (2,LMAX2+1, LMAX2+1) where LMAX2 is", lmax2
		print*, "Input array is dimensioned ", size(sh2(:,1,1)),  size(sh2(1,:,1)), size(sh2(1,1,:))
		stop
	elseif (size(shout(:,1,1)) < 2 .or. size(shout(1,:,1)) < lmax1+lmax2+1 .or. size(shout(1,1,:)) < lmax1+lmax2+1) then
		print*, "Error --- SHMultiply"
		print*, "SHOUT must be dimensioned as (2, LMAX1+LMAX2+1, LMAX1+LMAX2+1) where LMAX1 and LMAX2 are", lmax1, lmax2
		print*, "Input array is dimensioned ", size(shout(:,1,1)),  size(shout(1,:,1)), size(shout(1,1,:))
		stop
	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "Error --- SHMultiply"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

     	if (present(precomp)) then
     		if (precomp /= 1 .and. precomp /=0) then
     			print*, "Error --- SHMultiply"
     			print*, "PRECOMP must be either 0 (do not precompute PLX) or 1 (precompute PLX)."
     			print*, "Input value is ", precomp
     			stop
     		endif
     	endif

	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error - SHExpandGLQ"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif
		mnorm = norm
	else
		mnorm = 1
	endif

	allocate(grid1glq(lmax1+lmax2+1, 2*(lmax1+lmax2)+1), stat = astat(1))
	allocate(grid2glq(lmax1+lmax2+1, 2*(lmax1+lmax2)+1), stat = astat(2))
	if (astat(1) /= 0 .or. astat(2) /= 0) then
		print*, "Error --- SHMultiply"
		print*, "Problem allocating arrays GRID1GLQ and GRID2GLQ", astat(1), astat(2)
		stop
	endif

	shout = 0.0d0
	zero = 0.0d0
	w = 0.0d0
	grid1glq = 0.0d0
	grid2glq = 0.0d0

	lmaxout = lmax1 + lmax2

	if (present(precomp)) then
		if (precomp == 0) then

			call PreCompute(lmaxout, zero, w, csphase = phase, norm = mnorm)

			call MakeGridGLQ(grid1glq, sh1(1:2,1:lmax1+1, 1:lmax1+1), lmaxout, zero = zero, csphase = phase, norm = mnorm)

			call MakeGridGLQ(grid2glq, sh2(1:2,1:lmax2+1, 1:lmax2+1), lmaxout, zero = zero, csphase = phase, norm = mnorm)

			grid1glq = grid1glq*grid2glq

			call SHExpandGLQ(shout, lmaxout, grid1glq, w, zero = zero, csphase = phase, norm = mnorm)

		else
			allocate ( plx(lmax1+lmax2+1, (lmax1+lmax2+1)*(lmax1+lmax2+2)/2 ), stat=astat(3) )
			if (astat(3) /=0) then
				print*, "Error --- SHMultiply"
				print*, "Problem allocating array PLX", astat(3)
				stop
			endif

			call PreCompute(lmaxout, zero, w, plx = plx, csphase = phase, norm = mnorm)

			call MakeGridGLQ(grid1glq, sh1(1:2,1:lmax1+1, 1:lmax1+1), lmaxout, plx = plx, csphase = phase, norm = mnorm)

			call MakeGridGLQ(grid2glq, sh2(1:2,1:lmax2+1, 1:lmax2+1), lmaxout, plx = plx, csphase = phase, norm = mnorm)

			grid1glq = grid1glq*grid2glq

			call SHExpandGLQ(shout, lmaxout, grid1glq, w, plx = plx, csphase = phase, norm = mnorm)

			deallocate (plx)

		endif

	else

		call PreCompute(lmaxout, zero, w, csphase = phase, norm = mnorm)

		call MakeGridGLQ(grid1glq, sh1(1:2,1:lmax1+1, 1:lmax1+1), lmaxout, zero = zero, csphase = phase, norm = mnorm)

		call MakeGridGLQ(grid2glq, sh2(1:2,1:lmax2+1, 1:lmax2+1), lmaxout, zero = zero, csphase = phase, norm = mnorm)

		grid1glq = grid1glq*grid2glq

		call SHExpandGLQ(shout, lmaxout, grid1glq, w, zero = zero, csphase = phase, norm = mnorm)

	endif

	deallocate(grid1glq)
	deallocate(grid2glq)

end subroutine SHMultiply


module mod_post
  !
  use mod_types
  use mod_common_mpi, only: myid,ierr,ijk_start, &
                            MPI_PROC_NULL,       &
                            top,bottom,          &
                            front,back,          &
                            left,right
  use mpi
  use mod_param,     only: lx,ly,lz
#if defined(_HEAT_TRANSFER)
  use mod_param,     only: kappa1,kappa2,deltaT
#endif
#if defined(_OPENACC)
  use cudafor
  use mod_common_mpi, only: mydev
#endif
  !
  implicit none
  !
  private
  public  :: wall_avg,time_avg,compute_vorticity,mixed_variables
  contains
  !
  subroutine wall_avg(idir,nx,ny,nz,ngx,ngy,ngz,dxi,dyi,dzi,nh_t,ka,tmp,time)
    !
    implicit none
    !
    integer , intent(in )                                      :: idir
    integer , intent(in )                                      :: nx,ny,nz
    integer , intent(in )                                      :: ngx,ngy,ngz
    real(rp), intent(in )                                      :: dxi,dyi,dzi
    integer , intent(in )                                      :: nh_t
    real(rp), intent(in ), dimension(     0:,     0:,     0:)  :: ka
    real(rp), intent(in ), dimension(1-nh_t:,1-nh_t:,1-nh_t:)  :: tmp
    real(rp), intent(in )                                      :: time
    !
    real(rp) :: dtdz,dtdy,dtdx,kap
    real(rp) :: lref,ka_ref
    real(rp) :: nusselt_up,nusselt_down
    integer  :: i,j,k,ip,jp,kp,im,jm,km
#if defined(_OPENACC)
    integer :: istat
    attributes(managed) :: ka, tmp
#endif
    !
    ka_ref = kappa2
    !
    select case(idir)
    !
    ! Z-ORIENTATION
    !
    case(3)
      !
      lref = lz
      nusselt_up = 0._rp
      !
      if(top.eq.MPI_PROC_NULL) then ! z - top boundary
        k  = nz+1
        km = nz
        !$acc kernels
        do j=1,ny
          do i=1,nx
            dtdz = (tmp(i,j,k)-tmp(i,j,km))*dzi
            kap  = 0.5_rp*(ka(i,j,k)+ka(i,j,km))
            nusselt_up = nusselt_up + kap*dtdz
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_up,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_up = (nusselt_up/(1._rp*ngx*ngy))*(lref/ka_ref/deltaT)
      !
      nusselt_down = 0._rp
      !
      if(bottom.eq.MPI_PROC_NULL) then ! z - bottom boundary
        k  = 0
        kp = 1
        !$acc kernels
        do j=1,ny
          do i=1,nx
            dtdz = (tmp(i,j,kp)-tmp(i,j,k))*dzi
            kap  = 0.5_rp*(ka(i,j,k)+ka(i,j,kp))
            nusselt_down = nusselt_down - kap*dtdz
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_down,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_down = (nusselt_down/(1._rp*ngx*ngy))*(lref/ka_ref/deltaT)
      !
      if(myid.eq.0) then
        open(94,file='data/post/wall/nusselt.out',position='append')
        write(94,'(3E15.7)') time,nusselt_down,nusselt_up
        close(94)
      endif
    !
    ! Y-ORIENTATION
    !
    case(2)
      !
      lref = ly
      nusselt_up = 0._rp
      !
      if(back.eq.MPI_PROC_NULL) then ! y - top boundary
        j  = ny+1
        jm = ny
        !$acc kernels
        do k=1,nz
          do i=1,nx
            dtdy = (tmp(i,j,k)-tmp(i,jm,k))*dyi
            kap  = 0.5_rp*(ka(i,j,k)+ka(i,jm,k))
            nusselt_up = nusselt_up + kap*dtdy
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_up,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_up = (nusselt_up/(1._rp*ngx*ngz))*(lref/ka_ref/deltaT)
      !
      nusselt_down = 0._rp
      !
      if(front.eq.MPI_PROC_NULL) then ! y - bottom boundary
        j  = 0
        jp = 1
        !$acc kernels
        do k=1,nz
          do i=1,nx
            dtdy = (tmp(i,jp,k)-tmp(i,j,k))*dyi
            kap  = 0.5_rp*(ka(i,j,k)+ka(i,jp,k))
            nusselt_down = nusselt_down - kap*dtdy
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_down,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_down = (nusselt_down/(1._rp*ngx*ngz))*(lref/ka_ref/deltaT)
      !
      if(myid.eq.0) then
        open(94,file='data/post/wall/nusselt.out',position='append')
        write(94,'(3E15.7)') time,nusselt_down,nusselt_up
        close(94)
      endif
    !
    ! X-ORIENTATION
    !
    case(1)
      !
      lref = lx
      nusselt_up = 0._rp
      !
      if(right.eq.MPI_PROC_NULL) then ! x - top boundary
        i  = nx+1
        im = nx
        !$acc kernels
        do k=1,nz
          do j=1,ny
            dtdx = (tmp(i,j,k)-tmp(im,j,k))*dxi
            kap  = 0.5_rp*(ka(i,j,k)+ka(im,j,k))
            nusselt_up = nusselt_up + kap*dtdx
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_up,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_up = (nusselt_up/(1._rp*ngy*ngz))*(lref/ka_ref/deltaT)
      !
      nusselt_down = 0._rp
      !
      if(left.eq.MPI_PROC_NULL) then ! x - bottom boundary
        i  = 0
        ip = 1
        !$acc kernels
        do k=1,nz
          do j=1,ny
            dtdx = (tmp(ip,j,k)-tmp(i,j,k))*dxi
            kap  = 0.5_rp*(ka(i,j,k)+ka(ip,j,k))
            nusselt_down = nusselt_down - kap*dtdx
          enddo
        enddo
        !$acc end kernels
      endif
      call mpi_allreduce(MPI_IN_PLACE,nusselt_down,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      nusselt_down = (nusselt_down/(1._rp*ngy*ngz))*(lref/ka_ref/deltaT)
      !
      if(myid.eq.0) then
        open(94,file='data/post/wall/nusselt.out',position='append')
        write(94,'(3E15.7)') time,nusselt_down,nusselt_up
        close(94)
      endif
    end select
    !
    return
  end subroutine wall_avg
  !
  subroutine time_avg(idir,do_avg,do_favre,is_stag,fname,n,ng,istep,istep_av,iout1d, &
                      nh_d,nh_v,nh_p,psi,rho_p,p,pout1,pout2,pvol1,pvol2)
    !
    ! writes the profile of a variable averaged
    ! over two domain directions
    !
    ! idir     -> the direction normal to the averaging plane
    ! do_avg   -> do or not averaging
    ! do_favre -> Favre or regular averaging
    ! is_stag  -> decide if "p" is a cell-centered or staggered variable
    ! fname    -> name of the file
    ! n        -> size of the input array
    ! ng       -> total size of computational domain
    ! istep    -> current time step
    ! istep_av -> size of statistical sample
    ! iout1d   -> print file every iout1d time steps
    ! idir     -> direction of the profile (all other directions are averaged)
    ! nh_      -> halos point
    ! psi      -> 3D vof field (0 --> liquid, 1 --> gas)
    ! rho_p    -> density of the phase (for compressible phase)
    ! p        -> 3D input scalar field to be averaged
    ! pout1    ->  first order time statistics of plane averaged field (mean)
    ! pout2    -> second order time statistics of plane averaged field (rms)
    ! pvol     ->  first order time statistics of volume averaged field (mean)
    ! pvol2    -> second order time statistics of volume averaged field (rms)
    !
    use mod_param, only: dl
    !
    implicit none
    !
    integer         , intent(in   )                                     :: idir
    logical         , intent(in   )                                     :: do_avg,do_favre
    integer         , intent(in   ), dimension(3)                       :: is_stag
    character(len=*), intent(in   )                                     :: fname
    integer         , intent(in   ), dimension(3)                       :: n,ng
    integer         , intent(in   )                                     :: istep,istep_av,iout1d
    integer         , intent(in   )                                     :: nh_d,nh_v,nh_p
    real(rp)        , intent(in   ), dimension(1-nh_v:,1-nh_v:,1-nh_v:) :: psi
    real(rp)        , intent(in   ), dimension(0     :,0     :,0     :) :: rho_p
    real(rp)        , intent(in   ), dimension(1-nh_p:,1-nh_p:,1-nh_p:) :: p
    real(rp)        , intent(inout), dimension(1:)                      :: pout1,pout2
    real(rp)        , intent(inout)                                     :: pvol1,pvol2
    !
    real(rp), allocatable, dimension(:) :: p1d1,p1d2,rhop
    real(rp) :: factor,factor2,p_dl12,p_avg
    integer  :: i,j,k,mm,qx,qy,qz
    integer  :: nx,ny,nz,ngx,ngy,ngz,ng_idir
    integer  :: start
    integer  :: iunit
#if defined(_OPENACC)
    integer :: istat
    attributes(managed) :: p,psi,rho_p,p1d1,p1d2,rhop,pout1,pout2
#endif
    !
    p_dl12 = dl(1)*dl(2)
    !
    nx      = n(1)
    ny      = n(2)
    nz      = n(3)
    ngx     = ng(1)
    ngy     = ng(2)
    ngz     = ng(3)
    ng_idir = ng(idir)
    start   = ijk_start(idir)
    !
    qx = is_stag(1)
    qy = is_stag(2)
    qz = is_stag(3)
    !
    allocate(p1d1(ng(idir)),p1d2(ng(idir)),rhop(ng(idir)))
    !
    iunit   = 10
    factor  = 1._rp*istep_av
    factor2 = 1._rp*ng_idir/(1._rp*ngx*ngy*ngz)
    !
    if(istep_av.eq.1) then
      do mm=1,ng_idir
        pout1(mm) = 0._rp
        pout2(mm) = 0._rp
      enddo
    endif
    !
    !$acc kernels
    do mm=1,ng_idir
      p1d1(mm)  = 0._rp
      p1d2(mm)  = 0._rp
      rhop(mm)  = 0._rp
    enddo
    !$acc end kernels
    !
    if(do_favre) then
      !
      ! Density-based averaging (Favre)
      !
      select case(idir)
      case(1)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + i
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              rhop(mm) = rhop(mm) + p_dl12*rho_p(i,j,k)
              p1d1(mm) = p1d1(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      case(2)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + j
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              rhop(mm) = rhop(mm) + p_dl12*rho_p(i,j,k)
              p1d1(mm) = p1d1(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      case(3)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + k
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              rhop(mm) = rhop(mm) + p_dl12*rho_p(i,j,k)
              p1d1(mm) = p1d1(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + p_dl12*rho_p(i,j,k)*(1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      end select
      !
      call mpi_allreduce(MPI_IN_PLACE,rhop(1),ng_idir,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      call mpi_allreduce(MPI_IN_PLACE,p1d1(1),ng_idir,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      call mpi_allreduce(MPI_IN_PLACE,p1d2(1),ng_idir,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      !
      !$acc kernels
      do mm=1,ng_idir
        p1d1(mm) = p1d1(mm)/(rhop(mm))
        p1d2(mm) = p1d2(mm)/(rhop(mm))
      enddo
      !$acc end kernels
      !
    else
      !
      ! Volumetric-based averaging (no Favre)
      !
      select case(idir)
      case(1)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + i
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              p1d1(mm) = p1d1(mm) + (1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + (1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      case(2)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + j
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              p1d1(mm) = p1d1(mm) + (1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + (1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      case(3)
        !$acc kernels
        do k=1,nz
          do j=1,ny
            do i=1,nx
              mm = start + k
              !
              p_avg    = 0.5_rp*(p(i,j,k)+p(i-qx,j-qy,k-qz))
              p1d1(mm) = p1d1(mm) + (1._rp-psi(i,j,k))*p_avg
              p1d2(mm) = p1d2(mm) + (1._rp-psi(i,j,k))*p_avg**2
              !
            enddo
          enddo
        enddo
        !$acc end kernels
      end select
      !
      call mpi_allreduce(MPI_IN_PLACE,p1d1(1),ng_idir,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      call mpi_allreduce(MPI_IN_PLACE,p1d2(1),ng_idir,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      !
      !$acc kernels
      do mm=1,ng_idir
        p1d1(mm) = p1d1(mm)*factor2
        p1d2(mm) = p1d2(mm)*factor2
      enddo
      !$acc end kernels
      !
    endif
    !
    ! decide or not to averaging
    !
    if(.not.do_avg) then
      !$acc kernels
      do mm=1,ng_idir
        pout1(mm) = p1d1(mm)
        pout2(mm) = p1d2(mm)
      enddo
      !$acc end kernels
    else
      !$acc kernels
      do mm=1,ng_idir
        pout1(mm) = ((factor-1._rp)*pout1(mm)+p1d1(mm))/factor
        pout2(mm) = ((factor-1._rp)*pout2(mm)+p1d2(mm))/factor
      enddo
      !$acc end kernels
    endif
    pvol1 = sum(pout1)
    pvol2 = sum(pout2)
    !
    ! print
    !  note: we put this condition on iout1d in order to ensure that the
    !        averaging frequency (iout_av) is indenpendent
    !        of the print frequency of the files (iout1d)
    !
    if(mod(istep,iout1d).eq.0) then
      if(myid.eq.0) then
        open(unit=iunit,file=fname)
        do mm=1,ng_idir
          write(iunit,'(3E15.7)') (mm-0.5_rp)*dl(idir),pout1(mm),pout2(mm)
        enddo
        close(iunit)
      endif
      pout1 = 0._rp
      pout2 = 0._rp
      pvol1 = 0._rp
      pvol2 = 0._rp
    endif
    deallocate(p1d1,p1d2,rhop)
    !
    return
  end subroutine time_avg
  !
  subroutine compute_vorticity(nx,ny,nz,dxi,dyi,dzi,nh_u,v,w,vor)
    !
    implicit none
    !
    integer , intent(in )                                     :: nx,ny,nz
    real(rp), intent(in )                                     :: dxi,dyi,dzi
    integer , intent(in )                                     :: nh_u
    real(rp), intent(in ), dimension(1-nh_u:,1-nh_u:,1-nh_u:) :: v,w
    real(rp), intent(out), dimension(     1:,     1:,     1:) :: vor
    !
    real(rp) :: vp,vm,wp,wm
    integer  :: i,j,k,im,jm,km,ip,jp,kp
#if defined(_OPENACC)
    integer :: istat
    attributes(managed) :: v, w
#endif
    !
    !$acc kernels
    do k=1,nz
      do j=1,ny
        do i=1,nx
          kp = k+1
          km = k-1
          jp = j+1
          jm = j-1
          ip = i+1
          im = i-1
          !
          vp = 0.25*(v(i,j,k)+v(i,jm,k)+v(i,j,kp)+v(i,jm,kp))
          vm = 0.25*(v(i,j,k)+v(i,jm,k)+v(i,j,km)+v(i,jm,km))
          wp = 0.25*(w(i,j,k)+w(i,j,km)+w(i,jp,k)+w(i,jp,km))
          wm = 0.25*(w(i,j,k)+w(i,j,km)+w(i,jm,k)+w(i,jm,km))
          !
          vor(i,j,k) = (wp-wm)*dyi-(vp-vm)*dzi
          !
        enddo
      enddo
    enddo
    !$acc end kernels
    !
    return
  end subroutine compute_vorticity
  !
  subroutine mixed_variables(nx,ny,nz,dxi,dyi,dzi,nh_u,nh_s1, &
                             u,v,w,s1, &
                             us1,vs1,ws1,uv,vw,wu)
    !
    implicit none
    !
    integer , intent(in )                                        :: nx,ny,nz
    real(rp), intent(in )                                        :: dxi,dyi,dzi
    integer , intent(in )                                        :: nh_u,nh_s1!,nh_s2
    real(rp), intent(in ), dimension(1-nh_u :,1-nh_u :,1-nh_u :) :: u,v,w
    real(rp), intent(in ), dimension(1-nh_s1:,1-nh_s1:,1-nh_s1:) :: s1 ! generic scalar
    real(rp), intent(out), dimension(      1:,      1:,      1:) :: us1,vs1,ws1
    real(rp), intent(out), dimension(      1:,      1:,      1:) :: uv ,vw ,wu
    !
    integer :: i,j,k,im,jm,km
#if defined(_OPENACC)
    integer :: istat
    attributes(managed) :: u,v,w,s1
#endif
    !
    !$acc kernels
    do k=1,nz
      do j=1,ny
        do i=1,nx
          km = k-1
          jm = j-1
          im = i-1
          !
          uv(i,j,k)  = 0.25_rp*(u(i,j,k)+u(im,j,k))*(v(i,j,k)+v(i,jm,k))
          vw(i,j,k)  = 0.25_rp*(v(i,j,k)+v(i,jm,k))*(w(i,j,k)+w(i,j,km))
          wu(i,j,k)  = 0.25_rp*(w(i,j,k)+w(i,j,km))*(u(i,j,k)+u(im,j,k))
          !
          us1(i,j,k) = 0.5_rp*(u(i,j,k)+u(im,j,k))*s1(i,j,k)
          vs1(i,j,k) = 0.5_rp*(v(i,j,k)+v(i,jm,k))*s1(i,j,k)
          ws1(i,j,k) = 0.5_rp*(w(i,j,k)+w(i,j,km))*s1(i,j,k)
          !
        enddo
      enddo
    enddo
    !$acc end kernels
    !
    return
  end subroutine mixed_variables
  !
end module mod_post


      PROGRAM xchstwo
C     driver for routine chstwo
      INTEGER NBINS,NPTS
      PARAMETER(NBINS=10,NPTS=2000)
      INTEGER i,ibin,idum,j
      REAL*8 chsq,df,expdev,prob,x,bins1(NBINS),bins2(NBINS)
      idum=-17
      do 11 j=1,NBINS
        bins1(j)=0.0
        bins2(j)=0.0
11    continue
      do 12 i=1,NPTS
        x=expdev(idum)
        ibin=x*NBINS/3.0+1
        if (ibin.le.NBINS) bins1(ibin)=bins1(ibin)+1.0
        x=expdev(idum)
        ibin=x*NBINS/3.0+1
        if (ibin.le.NBINS) bins2(ibin)=bins2(ibin)+1.0
12    continue
      call chstwo(bins1,bins2,NBINS,0,df,chsq,prob)
      write(*,'(1x,t10,a,t25,a)') 'Dataset 1','Dataset 2'
      do 13 i=1,NBINS
        write(*,'(1x,2f15.2)') bins1(i),bins2(i)
13    continue
      write(*,'(/1x,t10,a,e12.4)') 'Chi-squared:',chsq
      write(*,'(1x,t10,a,e12.4)') 'Probability:',prob
      END


C$Procedure      CYLLAT ( Cylindrical to latitudinal )

      SUBROUTINE CYLLAT ( R, LONGC, Z,  RADIUS, LONG, LAT )

C$ Abstract
C
C     Convert from cylindrical to latitudinal coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION    R
      DOUBLE PRECISION    LONGC
      DOUBLE PRECISION    Z
      DOUBLE PRECISION    RADIUS
      DOUBLE PRECISION    LONG
      DOUBLE PRECISION    LAT

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     R          I   Distance of point from Z axis.
C     LONGC      I   Cylindrical angle of point from XZ plane(radians).
C     Z          I   Height of point above XY plane.
C     RADIUS     O   Distance of point from origin.
C     LONG       O   Longitude of point (radians).
C     LAT        O   Latitude of point (radians).
C
C$ Detailed_Input
C
C     R          Distance of the input point from Z axis.
C
C     LONGC      Cylindrical angle of the point from XZ plane (radians).
C
C     Z          Height of the point above XY plane.
C
C$ Detailed_Output
C
C     RADIUS     Distance of the input point from origin.
C
C     LONG       Longitude (i.e. angle from the XZ plane) of the input
C                point (radians). LONG is set equal to LONGC.
C
C     LAT        Latitude (i.e. angle above the XY plane) of the input
C                point (radians). The range of LAT is [-pi, pi].
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine converts coordinates given in cylindrical
C     coordinates to coordinates in latitudinal coordinates.
C
C     Latitudinal coordinates are the same coordinates as use for
C     the earth.  Latitude refers to angle above the equator, longitude
C     to angle east from a meridian, and radius to the distance from
C     an origin.
C
C$ Examples
C
C     Below are two tables:  The first is a set of input values
C     the second is the result of the following sequence of
C     calls to Spicelib routines.  Note all input and output angular
C     quantities are in degrees.
C
C         CALL CONVRT ( LONGC, 'DEGREES', 'RADIANS', LONGC     )
C
C         CALL CYLLAT ( R,      LONGC, Z,  RADIUS,   LONG, LAT )
C
C         CALL CONVRT ( LONG,  'RADIANS', 'DEGREES', LONG      )
C         CALL CONVRT ( LAT,   'RADIANS', 'DEGREES', LAT       )
C
C
C
C     Inputs:                         Results:
C
C     R        LONGC    Z             RADIUS   LONG     LAT
C     ------   ------   ------        ------   ------   ------
C     1.0000     0       0            1.0000     0        0
C     1.0000    90.00    0            1.0000    90.00     0
C     1.0000   180.00    1.000        1.4142   180.00    45.00
C     1.0000   180.00   -1.000        1.4142   180.00   -45.00
C     0.0000   180.00    1.000        1.0000   180.00    90.00
C     0.0000    33.00    0            0.0000    33.00     0.00
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.2, 22-AUG-2001 (EDW)
C
C        Corrected ENDIF to END IF.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     cylindrical to latitudinal
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     Local Variables
C
      DOUBLE PRECISION BIG
      DOUBLE PRECISION X
      DOUBLE PRECISION Y

      DOUBLE PRECISION RHO
      DOUBLE PRECISION LATTUD

C
C     Convert the input cylindrical coordinates to latitudinal
C     coordinates, storing in temporary variables.
C
      BIG = MAX( DABS(R), DABS(Z) )

      IF ( BIG .GT. 0 ) THEN
         X   = R/BIG
         Y   = Z/BIG
         RHO = BIG * DSQRT( X*X + Y*Y )
      ELSE
         RHO = 0.0D0
      END IF

      IF (RHO.EQ.0.D0) THEN
         LATTUD = 0.D0
      ELSE
         LATTUD = DATAN2 (Z,R)
      END IF
C
C     Move results to output variables
C
      LONG   = LONGC
      RADIUS = RHO
      LAT    = LATTUD
C
      RETURN
      END


!----------------------------------------
subroutine add_laplacian(phi, dphi, coef, l, m, n)
  !
  ! dphi += delta_i[ coef*delta_i[phi] ]
  !
  ! direction i should be the first one
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8, dimension(l, m, n), intent(in) :: phi
  real*8, dimension(l, m, n), intent(inout) :: dphi
  real*8 :: coef, fx, fxm

  !f2py intent(inplace):: phi, dphi

  integer:: i, j, k

  do k = 1, l
     do j = 1, m
        ! assume no flux at left boundary
        fxm = 0.
        do i = 1, n-1
           fx = phi(k,j,i+1)-phi(k,j,i)
           dphi(k,j,i) = dphi(k,j,i) +  coef*(fx-fxm)
           fxm = fx
        enddo
        ! assume no flux at right boundary
        fx = 0.
        i = n
        dphi(k,j,i) = dphi(k,j,i) +  coef*(fx-fxm)
     enddo
  enddo

end subroutine add_laplacian

!----------------------------------------
subroutine add_laplacian_uxx(phi, dphi, coef, l, m, n)
  !
  ! dphi += delta_i[ coef*delta_i[phi] ]
  !
  ! direction i should be the first one
  !
  ! special case for velocity 'u' along 'x'
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8, dimension(l, m, n), intent(in) :: phi
  real*8, dimension(l, m, n), intent(inout) :: dphi
  real*8 :: coef, fx, fxm

  !f2py intent(inplace):: phi, dphi

  integer:: i, j, k

  do k = 1, l
     do j = 1, m
        ! this is the exception for u_xx
        fxm = phi(k,j,1)
        do i = 1, n-1
           fx = phi(k,j,i+1)-phi(k,j,i)
           dphi(k,j,i) = dphi(k,j,i) +  coef*(fx-fxm)
           fxm = fx
        enddo
        ! assume no flux at right boundary
        !fx = 0.
        !i = n
        !dphi(k,j,i) = dphi(k,j,i) +  coef*(fx-fxm)
     enddo
  enddo

end subroutine add_laplacian_uxx


!
! This sample illustrates the use of cufftBox3d and cufftXtSetDistribution
! to support arbitrary user data distributions.
!
! It performs
! - Forward FFT
! - Element wise kernel
! - Inverse FFT
!
program cufftmp_c2c_pencils
    use iso_c_binding
    use cudafor
    use cufftXt
    use cufft
    use mpi
    implicit none

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

    ! cufft-related
    integer :: plan
    integer(c_size_t) :: worksize(1)
    type(cudaLibXtDesc), pointer :: u_desc
    type(cudaXtDesc), pointer    :: u_descptr
    complex, pointer, device     :: u_dptr(:,:,:)
    integer(kind=cuda_stream_kind) :: stream
    integer :: local_cshape_in(3), local_cshape_out(3)
    type(cufftBox3d), dimension(:), allocatable :: input_boxes, output_boxes

    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))
    nranks1d = sqrt(real(size))
    if (nranks1d * nranks1d .ne. size) then
        print*,"The number of MPI ranks should be a perfect square"
        call mpi_finalize(ierr)
    end if

    call checkCuda(cudaSetDevice(mod(rank, ndevices)))
    whichgpu(1) = mod(rank, ndevices)
    print*,"Hello from rank ", rank, " gpu id", mod(rank, ndevices), "size", size

    ! Define custom data distribution
    n = 32
    nx = n * nranks1d
    ny = nx
    nz = nx

    ! Let input data distributed in X and Y, contiguous at Z
    ! Let output data distributed in X and Z
    local_cshape_in = [nz, n, n]
    local_cshape_out = [n, ny, n]
    if (rank == 0) then
        write(*,*) "local_cshape_in (z,y,x) z fast  :", local_cshape_in(1), local_cshape_in(2), local_cshape_in(3)
        write(*,*) "local_cshape_out (z,y,x) z fast:", local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)
    end if

    ! cufftBox3d boxes are defined as { {x_start, y_start, z_start}, {x_end, y_end, z_end}, {x%strides, y%strides, z%strides} }
    ! where
    ! - {x/y/z}_{start/end} are the lower and upper corner of the boxes relatived to the global 3D box (of size nx * ny * nz)
    ! - {x/y/z} strides are the local strides
    allocate(input_boxes(0:size-1), output_boxes(0:size-1) )
    do i = 0 , nranks1d - 1
        do j = 0, nranks1d - 1
            ! input data are pencils in X and Y, contiguous at Z
            input_boxes( i*nranks1d + j )%lower = [i*n, j*n, 0]                !x,y,z start global Idx
            input_boxes( i*nranks1d + j )%upper = [(i+1)*n, (j+1)*n, nz]       !x,y,z end global Idx
            input_boxes( i*nranks1d + j )%strides = [n * nz, nz, 1]            !x,y,z stride local

            ! output data are pencils in X and Z
            output_boxes( i*nranks1d + j )%lower = [i*n, 0, j*n]              !x,y,z start global Idx
            output_boxes( i*nranks1d + j )%upper = [(i+1)*n, ny, (j+1)*n]     !x,y,z end global Idx
            output_boxes( i*nranks1d + j )%strides = [n * ny, n, 1]           !x,y,z stride local
        end do
    end do

	write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "lower", input_boxes(rank)%lower
    write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "upper", input_boxes(rank)%upper
    write(*,'(A18, I1, A10, 3I10)') "my rank", rank, "strides", input_boxes(rank)%strides

    ! Generate local, distributed CPU data
    allocate(u(local_cshape_in(1), local_cshape_in(2), local_cshape_in(3)))
    allocate(u_permuted(local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)))
    allocate(ref(local_cshape_in(1), local_cshape_in(2), local_cshape_in(3)))
    call generate_random(local_cshape_in(1), local_cshape_in(2), local_cshape_in(3), u)
    ref = u
    u_permuted = (0.0,0.0)

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

    call checkCufft(cufftCreate(plan))
    call checkCuda(cudaStreamCreate(stream))
    call checkCufft(cufftMpAttachComm(plan, CUFFT_COMM_MPI, MPI_COMM_WORLD), 'cufftMpAttachComm error')
    call checkCufft(cufftXtSetDistribution(plan, input_boxes(rank), output_boxes(rank)))

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

    call checkCufft(cufftXtMalloc(plan, u_desc, CUFFT_XT_FORMAT_DISTRIBUTED_INPUT), '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')
    call checkCuda(cudaStreamSynchronize(stream))

    ! 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_cshape_out(1), local_cshape_out(2), local_cshape_out(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)
    call c_f_pointer(u_descptr%data(1), u_dptr, [local_cshape_out(1), local_cshape_out(2), local_cshape_out(3)])
    !$cuf kernel do (3)
    do k =1, local_cshape_out(3)
        do j = 1, local_cshape_out(2)
            do i = 1, local_cshape_out(1)
                u_dptr(i,j,k) = u_dptr(i,j,k) / real(nx*ny*nz)
            end do
        end do
    end do
    call checkCuda(cudaDeviceSynchronize())

    ! 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_cshape_out(1), local_cshape_out(2), local_cshape_out(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 checkCufft(cudaStreamDestroy(stream))

    call checkNormDiff(local_cshape_in(1), local_cshape_in(2), local_cshape_in(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

    deallocate(input_boxes, output_boxes)
    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

end program cufftmp_c2c_pencils


SUBROUTINE DCSYMBDL(A,M,N,NN,EPS,Z,W,L,LI,LJ,IER)
!**********************************************************************
!  GAUSS METHOD FOR A SYMMETRIC BAND MATRIX WITH A SHORT WIDTH.       *
!  THIS ROUTINE IS FOR A VECTOR COMPUTER.                             *
!                                                                     *
!  PARAMETERS:                                                        *
!   ON ENTRY:                                                         *
!     A      THE ARRAY WITH DIMENSION (M+1)*N WHICH CONTAINS          *
!            THE LOWER BAND MATRIX IN ROW-WISE.                       *
!     M      THE HALF BAND WIDTH OF THE MATRIX A, EXCLUDING DIADONALS.*
!     N      THE ORDER OF THE MATRIX A.                               *
!     NN     THE ORDER OF WORKING ARRAYS L, LI, AND LJ.               *
!     EPS    THE TOLERANCE FOR PIVOTAL ELEMENTS.                      *
!   ON RETURN:                                                        *
!     A      THE LOWER TRIANGULAR MATRIX L AFTER DECOMPOSITION.       *
!     IER    ERROR CODE. IF IER=0, NORMAL RETURN.                     *
!   OTHERS: WORKING PARAMETERS.                                       *
!                                                                     *
!  COPYRIGHT:       FUMIKO NAGAHORI    1 SEP. 1991      VER. 1        *
!    modified: Kensuke Konishi 2018 in Paris
!**********************************************************************
    use parameters
    implicit none
    INTEGER:: N,M,MM,NN
    INTEGER:: L(NN),LI(NN),LJ(NN),IER
    double precision::EPS
    COMPLEX(dp):: A((M+1)*N),Z(M+1),W(M+1)
    INTEGER:: I,J,K,IJ,KK,NK,NKK,NKI
    COMPLEX(dp):: PIV

    IER = 0
    IJ = 0
    DO I=1,M
        IJ = IJ + 1
        LI(IJ) = I + 1
        LJ(IJ) = 2
        L(IJ) = M * (I-1) + 1
        DO J=I+1,M
            IJ = IJ + 1
            L(IJ) = L(IJ-1) + M + 1
            LI(IJ) = LI(IJ-1) + 1
            LJ(IJ) = LJ(IJ-1) + 1
        enddo
    enddo
    MM = (M+1) * M / 2
    DO K=1,N-M
        NK = (M+1) * (K-1) + 1
        IF (cdabs(A(NK+M)) < EPS) THEN
            WRITE(*,*) '(SUBR. SYMBDL) SINGULAR AT STEP = ', K
            IER = 1
            RETURN
        ENDIF
        PIV = 1 / A(NK+M)
        DO J=2,M+1
            Z(J) = -A(NK+M*J)
            W(J) = A(NK+M*J) * PIV
            A(NK+M*J) = W(J)
        enddo

        KK = NK + M + M
        !VORTION VEC
        A(KK+L(1:mm)) = A(KK+L(1:mm)) + W(LJ(1:mm)) * Z(LI(1:mm))
    enddo

    DO K=N-M+1,N-1
        NK = (M+1) * (K-1) + 1
        NKK = (M+1) * K - 1
        IF (cdabs(A(NK+M)) < EPS) THEN
            WRITE(*,*) '(SUBR. SYMBDL) SINGULAR AT STEP = ', K
            IER = 1
            RETURN
        ENDIF
        PIV = 1 / A(NK+M)
        DO  J=2,N-K+1
            Z(J) = -A(NK+M*J)
            W(J) = A(NK+M*J) * PIV
            A(NK+M*J) = W(J)
            NKI = NKK + M * (J-1)
            A(NKI+2:nki+j) = A(NKI+2:nki+j) + W(J) * Z(2:j)
        enddo
    enddo
    RETURN
END SUBROUTINE DCSYMBDL

SUBROUTINE DCSBDLV(A,B,M,N,NP,Z)
!**********************************************************************
!  GAUSS METHOD FOR A SYMMETRIC BAND MATRIX WITH A SHORT WIDTH.       *
!  THIS ROUTINE IS FOR A VECTOR COMPUTER.                             *
!                                                                     *
!  PARAMETERS:                                                        *
!   ON ENTRY:                                                         *
!     A      THE ARRAY WITH DIMENSION (M+1),N WHICH CONTAINS          *
!            THE LEFT HAND SIDE LOWER BAND MATRIX.                    *
!     M      THE HALF BAND WIDTH OF THE MATRIX A, EXCLUDING DIADONALS.*
!     N      THE ORDER OF THE MATRIX A.                               *
!     EPS    THE TOLERANCE FOR PIVOTAL ELEMENTS.                      *
!     B      RIGHT HAND SIDE VECTOR                                   *
!   ON RETURN:                                                        *
!     B      SOLUTION.                                                *
!     IER    ERROR CODE. IF IER=0, NORMAL RETURN.                     *
!   OTHERS: WORKING PARAMETERS.                                       *
!                                                                     *
!  COPYRIGHT:       FUMIKO NAGAHORI    1 SEP. 1991      VER. 1        *
! modified: Kensuke Konishi 2018 in Paris
!**********************************************************************
    use parameters
    implicit none
    INTEGER:: M,N
    integer,intent(in):: NP
    COMPLEX(dp):: A(M+1,N),B(N),Z(N)
    INTEGER:: MM,J,K,I1
    COMPLEX(dp):: SUM

    ! FORWARD SUBSTITUTION
    MM = M + 1
    IF (MM < 3) THEN
        Z(NP) = B(NP)
        DO J=NP+1,N
            Z(J) = B(J) - A(1,J) * Z(J-1)
        enddo
        B(N) = Z(N) / A(M+1,N)
    ELSE
        Z(NP) = B(NP)
        Z(NP+1) = B(NP+1) - A(MM-1,NP+1) * Z(NP)
        DO J=NP+2,N
            IF (J > NP-1+MM) THEN
                I1 = 1
            ELSE
                I1 = NP-1+MM - J + 1
            ENDIF
            SUM = 0
            DO K=I1,MM-1
                SUM = SUM + A(K,J) * Z(J-MM+K)
            enddo
            Z(J) = B(J) - SUM
        enddo

        Z(n-1:n) = Z(n-1:n) / A(M+1,n-1:n)

        B(N) = Z(N)
        B(N-1) = Z(N-1) - A(MM-1,N) * Z(N)
    ENDIF
    RETURN
END SUBROUTINE DCSBDLV

SUBROUTINE DCSBDLV0(A,B,M,N,Z)
!**********************************************************************
!  GAUSS METHOD FOR A SYMMETRIC BAND MATRIX WITH A SHORT WIDTH.       *
!  THIS ROUTINE IS FOR A VECTOR COMPUTER.                             *
!                                                                     *
!  PARAMETERS:                                                        *
!   ON ENTRY:                                                         *
!     A      THE ARRAY WITH DIMENSION (M+1),N WHICH CONTAINS          *
!            THE LEFT HAND SIDE LOWER BAND MATRIX.                    *
!     M      THE HALF BAND WIDTH OF THE MATRIX A, EXCLUDING DIADONALS.*
!     N      THE ORDER OF THE MATRIX A.                               *
!     EPS    THE TOLERANCE FOR PIVOTAL ELEMENTS.                      *
!     B      RIGHT HAND SIDE VECTOR                                   *
!   ON RETURN:                                                        *
!     B      SOLUTION.                                                *
!     IER    ERROR CODE. IF IER=0, NORMAL RETURN.                     *
!   OTHERS: WORKING PARAMETERS.                                       *
!                                                                     *
!  COPYRIGHT:       FUMIKO NAGAHORI    1 SEP. 1991      VER. 1        *
!**********************************************************************
    use parameters
    IMPLICIT NONE
    integer:: M,N
    complex(dp):: A(M+1,N),B(N),Z(N)
    integer:: MM,J,K,I1,J1
    complex(dp):: SUM

    ! FORWARD SUBSTITUTION
    MM = M + 1
    IF (MM < 3) THEN
        Z(1) = B(1)
        DO J=2,N
            Z(J) = B(J) - A(1,J) * Z(J-1)
        enddo
        DO J=1,N
            Z(J) = Z(J) / A(M+1,J)
        enddo
        B(N) = Z(N)
        DO J=1,N-1
            B(N-J) = Z(N-J) - A(1,N-J+1) * B(N-J+1)
        enddo
    ELSE
        Z(1) = B(1)
        Z(2) = B(2) - A(M-1,2) * Z(1)
        DO J=3,N
            IF (J > MM) THEN
                I1 = 1
            ELSE
                I1 = MM - J + 1
            ENDIF
            SUM = 0
            DO K=I1,MM-1
                SUM = SUM + A(K,J) * Z(J-MM+K)
            enddo
            Z(J) = B(J) - SUM
        enddo

        Z(1:n) = Z(1:n) / A(M+1,1:n)

        B(N) = Z(N)
        B(N-1) = Z(N-1) - A(MM-1,N) * Z(N)
        DO J=3,N
            J1 = N - J + 1
            I1 = 1
            IF (J < MM) I1 = MM - J + 1
            SUM = 0
            DO K=I1,MM-1
                SUM = SUM + A(K,MM-K+J1) * B(MM-K+J1)
            enddo
            B(J1) = Z(J1) - SUM
        enddo
    ENDIF
    RETURN
END


      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
*     ..
*
*     Purpose
*     =======
*
*     DLASQ1 computes the singular values of a real N-by-N bidiagonal
*     matrix with diagonal D and off-diagonal E. The singular values are
*     computed to high relative accuracy, barring over/underflow or
*     denormalization. The algorithm is described in
*
*     "Accurate singular values and differential qd algorithms," by
*     K. V. Fernando and B. N. Parlett,
*     Numer. Math., Vol-67, No. 2, pp. 191-230,1994.
*
*     See also
*     "Implementation of differential qd algorithms," by
*     K. V. Fernando and B. N. Parlett, Technical Report,
*     Department of Mathematics, University of California at Berkeley,
*     1994 (Under preparation).
*
*     Arguments
*     =========
*
*  N       (input) INTEGER
*          The number of rows and columns in the matrix. N >= 0.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, D contains the diagonal elements of the
*          bidiagonal matrix whose SVD is desired. On normal exit,
*          D contains the singular values in decreasing order.
*
*  E       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, elements E(1:N-1) contain the off-diagonal elements
*          of the bidiagonal matrix whose SVD is desired.
*          On exit, E is overwritten.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the algorithm did not converge;  i
*                specifies how many superdiagonals did not converge.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   MEIGTH
      PARAMETER          ( MEIGTH = -0.125D0 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
      DOUBLE PRECISION   TEN
      PARAMETER          ( TEN = 10.0D0 )
      DOUBLE PRECISION   HUNDRD
      PARAMETER          ( HUNDRD = 100.0D0 )
      DOUBLE PRECISION   TWO56
      PARAMETER          ( TWO56 = 256.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            RESTRT
      INTEGER            I, IERR, J, KE, KEND, M, NY
      DOUBLE PRECISION   DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN,
     $                   SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -2
         CALL XERBLA( 'DLASQ1', -INFO )
         RETURN
      ELSE IF( N.EQ.0 ) THEN
         RETURN
      ELSE IF( N.EQ.1 ) THEN
         D( 1 ) = ABS( D( 1 ) )
         RETURN
      ELSE IF( N.EQ.2 ) THEN
         CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
         D( 1 ) = SIGMX
         D( 2 ) = SIGMN
         RETURN
      END IF
*
*     Estimate the largest singular value
*
      SIGMX = ZERO
      DO 10 I = 1, N - 1
         SIGMX = MAX( SIGMX, ABS( E( I ) ) )
   10 CONTINUE
*
*     Early return if sigmx is zero (matrix is already diagonal)
*
      IF( SIGMX.EQ.ZERO )
     $   GO TO 70
*
      DO 20 I = 1, N
         D( I ) = ABS( D( I ) )
         SIGMX = MAX( SIGMX, D( I ) )
   20 CONTINUE
*
*     Get machine parameters
*
      EPS = DLAMCH( 'EPSILON' )
      SFMIN = DLAMCH( 'SAFE MINIMUM' )
*
*     Compute singular values to relative accuracy TOL
*     It is assumed that tol**2 does not underflow.
*
      TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) )
      TOL = TOLMUL*EPS
      TOL2 = TOL**2
*
      THRESH = SIGMX*SQRT( SFMIN )*TOL
*
*     Scale matrix so the square of the largest element is
*     1 / ( 256 * SFMIN )
*
      SCL = SQRT( ONE / ( TWO56*SFMIN ) )
      SMALL2 = ONE / ( TWO56*TOLMUL**2 )
      CALL DCOPY( N, D, 1, WORK( 1 ), 1 )
      CALL DCOPY( N-1, E, 1, WORK( N+1 ), 1 )
      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR )
      CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1,
     $             IERR )
*
*     Square D and E (the input for the qd algorithm)
*
      DO 30 J = 1, 2*N - 1
         WORK( J ) = WORK( J )**2
   30 CONTINUE
*
*     Apply qd algorithm
*
      M = 0
      E( N ) = ZERO
      DX = WORK( 1 )
      DM = DX
      KE = 0
      RESTRT = .FALSE.
      DO 60 I = 1, N
         IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2*
     $       ( DM / DBLE( I-M ) ) ) THEN
            NY = I - M
            IF( NY.EQ.1 ) THEN
               GO TO 50
            ELSE IF( NY.EQ.2 ) THEN
               CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 )
               D( M+1 ) = SIG1
               D( M+2 ) = SIG2
            ELSE
               KEND = KE + 1 - M
               CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ),
     $                      WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND,
     $                      INFO )
*
*                 Return, INFO = number of unconverged superdiagonals
*
               IF( INFO.NE.0 ) THEN
                  INFO = INFO + I
                  RETURN
               END IF
*
*                 Undo scaling
*
               DO 40 J = M + 1, M + NY
                  D( J ) = SQRT( D( J ) )
   40          CONTINUE
               CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY,
     $                      IERR )
            END IF
   50       CONTINUE
            M = I
            IF( I.NE.N ) THEN
               DX = WORK( I+1 )
               DM = DX
               KE = I
               RESTRT = .TRUE.
            END IF
         END IF
         IF( I.NE.N .AND. .NOT.RESTRT ) THEN
            DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) )
            IF( DM.GT.DX ) THEN
               DM = DX
               KE = I
            END IF
         END IF
         RESTRT = .FALSE.
   60 CONTINUE
      KEND = KE + 1
*
*     Sort the singular values into decreasing order
*
   70 CONTINUE
      CALL DLASRT( 'D', N, D, INFO )
      RETURN
*
*     End of DLASQ1
*
      END


      SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q,
     $                   LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute one recursion of the conventional Kalman filter
C     equations. This is one update of the Riccati difference equation
C     and the Kalman filter gain.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e., the order of the
C             matrices P      and A .  N >= 0.
C                       i|i-1      i
C
C     M       (input) INTEGER
C             The actual input dimension, i.e., the order of the matrix
C             Q .  M >= 0.
C              i
C
C     L       (input) INTEGER
C             The actual output dimension, i.e., the order of the matrix
C             R .  L >= 0.
C              i
C
C     P       (input/output) DOUBLE PRECISION array, dimension (LDP,N)
C             On entry, the leading N-by-N part of this array must
C             contain P     , the state covariance matrix at instant
C                      i|i-1
C             (i-1). The upper triangular part only is needed.
C             On exit, if INFO = 0, the leading N-by-N part of this
C             array contains P     , the state covariance matrix at
C                             i+1|i
C             instant i. The strictly lower triangular part is not set.
C             Otherwise, the leading N-by-N part of this array contains
C             P     , its input value.
C              i|i-1
C
C     LDP     INTEGER
C             The leading dimension of array P.  LDP >= MAX(1,N).
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain A ,
C                                                                 i
C             the state transition matrix of the discrete system at
C             instant i.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain B ,
C                                                                 i
C             the input weight matrix of the discrete system at
C             instant i.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading L-by-N part of this array must contain C ,
C                                                                 i
C             the output weight matrix of the discrete system at
C             instant i.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,L).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,M)
C             The leading M-by-M part of this array must contain Q ,
C                                                                 i
C             the input (process) noise covariance matrix at instant i.
C             The diagonal elements of this array are modified by the
C             routine, but are restored on exit.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,M).
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,L)
C             On entry, the leading L-by-L part of this array must
C             contain R , the output (measurement) noise covariance
C                      i
C             matrix at instant i.
C             On exit, if INFO = 0, or INFO = L+1, the leading L-by-L
C                                                                  1/2
C             upper triangular part of this array contains (RINOV )   ,
C                                                                i
C             the square root (left Cholesky factor) of the covariance
C             matrix of the innovations at instant i.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,L).
C
C     K       (output) DOUBLE PRECISION array, dimension (LDK,L)
C             If INFO = 0, the leading N-by-L part of this array
C             contains K , the Kalman filter gain matrix at instant i.
C                       i
C             If INFO > 0, the leading N-by-L part of this array
C             contains the matrix product P     C'.
C                                          i|i-1 i
C
C     LDK     INTEGER
C             The leading dimension of array K.  LDK >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used to test for near singularity of
C             the matrix RINOV . If the user sets TOL > 0, then the
C                             i
C             given value of TOL is used as a lower bound for the
C             reciprocal condition number of that matrix; a matrix whose
C             estimated condition number is less than 1/TOL is
C             considered to be nonsingular. If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = L*L*EPS, is used instead, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (L)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an
C             estimate of the reciprocal of the condition number (in the
C             1-norm) of the matrix RINOV .
C                                        i
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= MAX(1,L*N+3*L,N*N,N*M).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value;
C             = k:  if INFO = k, 1 <= k <= L, the leading minor of order
C                   k of the matrix RINOV  is not positive-definite, and
C                                        i
C                   its Cholesky factorization could not be completed;
C             = L+1: the matrix RINOV  is singular, i.e., the condition
C                                    i
C                   number estimate of RINOV  (in the 1-norm) exceeds
C                                           i
C                   1/TOL.
C
C     METHOD
C
C     The conventional Kalman filter gain used at the i-th recursion
C     step is of the form
C
C                            -1
C        K  = P     C'  RINOV  ,
C         i    i|i-1 i       i
C
C     where RINOV  = C P     C' + R , and the state covariance matrix
C                i    i i|i-1 i    i
C
C     P      is updated by the discrete-time difference Riccati equation
C      i|i-1
C
C        P      = A  (P      - K C P     ) A'  + B Q B'.
C         i+1|i    i   i|i-1    i i i|i-1   i     i i i
C
C     Using these two updates, the combined time and measurement update
C     of the state X      is given by
C                   i|i-1
C
C        X      = A X      + A K (Y  - C X     ),
C         i+1|i    i i|i-1    i i  i    i i|i-1
C
C     where Y  is the new observation at step i.
C            i
C
C     REFERENCES
C
C     [1] Anderson, B.D.O. and Moore, J.B.
C         Optimal Filtering,
C         Prentice Hall, Englewood Cliffs, New Jersey, 1979.
C
C     [2] Verhaegen, M.H.G. and Van Dooren, P.
C         Numerical Aspects of Different Kalman Filter Implementations.
C         IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately
C
C             3   2
C      3/2 x N + N  x (3 x L + M/2)
C
C     operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen,
C     M. Vanbegin, and P. Van Dooren.
C
C     REVISIONS
C
C     February 20, 1998, November 20, 2003, April 20, 2004.
C
C     KEYWORDS
C
C     Kalman filtering, optimal filtering, recursive estimation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR,
     $                  LDWORK, M, N
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                  K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*)
C     .. Local Scalars ..
      INTEGER           J, JWORK, LDW, N1
      DOUBLE PRECISION  RCOND, RNORM, TOLDEF
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANSY
      EXTERNAL          DLAMCH, DLANSY
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON,
     $                  DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      N1 = MAX( 1, N )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( L.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDP.LT.N1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.N1 ) THEN
         INFO = -7
      ELSE IF( LDB.LT.N1 ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, L ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF( LDR.LT.MAX( 1, L ) ) THEN
         INFO = -15
      ELSE IF( LDK.LT.N1 ) THEN
         INFO = -17
      ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN
         INFO = -21
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FB01VD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, L ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and
C     PC' in K. (The content of DWORK on exit from MB01RD is used.)
C     Workspace: need L*N.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code.)
C
      CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C,
     $             LDC, P, LDP, DWORK, LDWORK, INFO )
      LDW = MAX( 1, L )
C
      DO 10 J = 1, L
         CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 )
   10 CONTINUE
C
      CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW )
      CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE,
     $            P, LDP, DWORK, LDW )
      CALL DSCAL( N, TWO, P, LDP+1 )
C
      DO 20 J = 1, L
         CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW )
         CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 )
   20 CONTINUE
C
C     Calculate the Cholesky decomposition U'U of the innovation
C     covariance matrix RINOV, and its reciprocal condition number.
C     Workspace: need L*N + 3*L.
C
      JWORK = L*N + 1
      RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) )
C
      TOLDEF = TOL
      IF ( TOLDEF.LE.ZERO )
     $   TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' )
      CALL DPOTRF( 'Upper', L, R, LDR, INFO )
      IF ( INFO.NE.0 )
     $   RETURN
C
      CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK),
     $             IWORK, INFO )
C
      IF ( RCOND.LT.TOLDEF ) THEN
C
C        Error return: RINOV is numerically singular.
C
         INFO = L+1
         DWORK(1) = RCOND
         RETURN
      END IF
C
      IF ( L.GT.1 )
     $   CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR )
C                                                          -1
C     Calculate the Kalman filter gain matrix  K = PC'RINOV .
C     Workspace: need L*N.
C
      CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L,
     $            ONE, R, LDR, K, LDK )
      CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L,
     $            ONE, R, LDR, K, LDK )
C
C     First part of the Riccati equation update: compute A(P-KCP)A'.
C     The upper triangular part of the symmetric matrix P-KCP is formed.
C     Workspace: need max(L*N,N*N).
C
      JWORK = 1
C
      DO 30 J = 1, N
         CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK),
     $               1, ONE, P(1,J), 1 )
         JWORK = JWORK + L
   30 CONTINUE
C
      CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A,
     $             LDA, P, LDP, DWORK, LDWORK, INFO )
C
C     Second part of the Riccati equation update: add BQB'.
C     Workspace: need N*M.
C
      CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B,
     $             LDB, Q, LDQ, DWORK, LDWORK, INFO )
      CALL DSCAL( M, TWO, Q, LDQ+1 )
C
C     Set the reciprocal of the condition number estimate.
C
      DWORK(1) = RCOND
C
      RETURN
C *** Last line of FB01VD ***
      END


      function bt12osc_eval_eq(per_dex, damp,
     :         c1, c2, c3, c4, c5, c6, c7, twopi)

! Eric's params equivalences:

!  c1 = A
!  c2 = B
!  c3 = 2.0
!  c4 = eps
!  c5 = alpha
!  c6 = n
!  c7 = delta

! Dates: 06/18/11 - Written by D. Boore
!        08/02/11 - Changed "BT11" to "BT12", in anticipation of the paper being published in 2012.

      eta = per_dex

      F = c1+c2*(1.0-eta**c3)/(1.0+eta**c3)

      bt12osc =
     :      1.0 + c4*(1.0/(twopi*damp))*(eta/(1.0+c5*eta**c6))**c7

      bt12osc_eval_eq = F * bt12osc

      return

      end


program main
use mpmodule   ! Пожключение модуля многократной точности
use p_mpfun_e1 ! Подключение модуля рассчета E_1 на многократной точности
use p_e1       ! Подключение модуля рассчета E_1 на четверной точности
implicit none

interface e141 ! Объявление родового имени для функций из разных модулей
module procedure e141_mp, e141_r16
end interface

integer  i, n
real(16) a, b, x, h
real(16) t1, t2 ! Переменные времени

character(2)  i_holder  ! Строка-держатель i
character(10) x_holder  ! Строка-держатель x
character(58) mp_number ! Строка-держатель численной части вывода mpwrite
character(9)  mp_extent ! Строка-держатель степенной части вывода mpwrite
character(61) mp_out    ! Строка-держатель числа со степенной частью в стандартном формате

type (mp_real) x_mp ! Объявление переменной x для рассчета на многократной точности

call mpinit (500) ! Инициализатор параметров MPFUN (таких как точность)
                  ! Подробнее смотри в руководстве или в файле mpmod90.f

! Вывод заголовка программы
write(*,'(/,2x,a,/)') 'Сравнение результатов вычисления E_1(x) при &
&разложении в ряд по полиномам Чебышева на четверной точности и &
&на многократной точности'

read(*,*) a, b, n

h=(b-a)/n

! Вывод заголовка таблицы
write(*,'(2x,a,11x,a,35x,a,55x,a)') 'x', 'e1_r16', 'e1_mpfun', 'time'

open(7,file='mp_output'); open(8,file='mp_output_copy') ! Открытие выходного файла и файла-копии
do i=0, n, 1

write(i_holder,'(i2)') i+1 ! i_holder используется при копировании строки bash-командой sed (строка 52)

x=a+h*i

write(x_holder,'(e10.4)') x ! Передача вычисленного аргумента
x_mp=MPREAL(x_holder)       ! переменной x_mp типа mp_real

t1=second() ! Процедура second описана в файле second.f (поставляется вместе с библиотекой MPFUN)
call mpwrite(7,e141(x_mp)) ! Вывод результата, полученного на многократной точности
t2=second()

call system("sed -n "//i_holder//"p mp_output >> mp_output_copy")  ! Копирование полученной строки в файл-копию
! Это необходимо, поскольку по каким-то причинам процедура mpwrite не позволяет оператору read параллельно считывать из файла

! Считывание степенной и численной части полученной строки
read(8,'(12x,a2,4x,a58)') mp_extent, mp_number

mp_out = trim(mp_number)//'E'//mp_extent ! Формирование строки-результата

! Вывод строки таблицы
write(*,'(2x,e10.4,e41.33,2x,a,e15.7)') x, e141(x), mp_out, t2-t1

enddo

close(8); close(7)

write(*,*) ' '

end program


c=======================================================================
c
c     subroutine NUHAT
c
c     Computing useful data for the shrinkage intensity
c     For further information please refer to the specification document
c     in the directory numx/src/rne/statistic/doc/
c
c-----------------------------------------------------------------------
      subroutine nuhat ( n, p, x, rhomean, cov, nuh )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : max. number of values                      integer
c            p      : number of assets (p > 1)                   integer
c            x      : asset(s) return(s) values (n*p)             double
c            rhomean: mean of the returns vector p                double
c            cov    : covariance matrix (p*p)                     double
c
c     OUTPUT
c            nuh    : (p*p)- matrix containing the nu matrix      double
c
c     CALL
c
c-----------------------------------------------------------------------
c
      implicit none
c
c Input/Output
c
      integer n, p
      double precision x(*), rhomean(*), cov(*), nuh(*)

c Local variables
      double precision rhotemp1, rhotemp2, temp1, temp2, sum
      integer i, j, k

      do i=1,p
        rhotemp1=rhomean(i)
        do j=1,p
            sum = 0.
            rhotemp2=rhomean(j)
            do k=1,n
                temp2 = (x((i-1)*n +k)- rhotemp1)
                temp1 = temp2 * temp2
                temp2 = temp2*(x((j-1)*n+k)- rhotemp2)
                temp2 = temp2 - cov((i-1)*p+j)
                temp2 = (temp1 - cov((i-1)*p+i)) * temp2
                sum = sum + temp2
            enddo
            nuh(((i-1)*p+j))= sum/n
        enddo
      enddo

      return
      end


      SUBROUTINE gauher(x,w,n)
      INTEGER n,MAXIT
      REAL w(n),x(n)
      DOUBLE PRECISION EPS,PIM4
      PARAMETER (EPS=3.D-14,PIM4=.7511255444649425D0,MAXIT=10)
      INTEGER i,its,j,m
      DOUBLE PRECISION p1,p2,p3,pp,z,z1
      m=(n+1)/2
      do 13 i=1,m
        if(i.eq.1)then
          z=sqrt(float(2*n+1))-1.85575*(2*n+1)**(-.16667)
        else if(i.eq.2)then
          z=z-1.14*n**.426/z
        else if (i.eq.3)then
          z=1.86*z-.86*x(1)
        else if (i.eq.4)then
          z=1.91*z-.91*x(2)
        else
          z=2.*z-x(i-2)
        endif
        do 12 its=1,MAXIT
          p1=PIM4
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=z*sqrt(2.d0/j)*p2-sqrt(dble(j-1)/dble(j))*p3
11        continue
          pp=sqrt(2.d0*n)*p2
          z1=z
          z=z1-p1/pp
          if(abs(z-z1).le.EPS)goto 1
12      continue
        pause 'too many iterations in gauher'
1       x(i)=z
        x(n+1-i)=-z
        w(i)=2.d0/(pp*pp)
        w(n+1-i)=w(i)
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/gauher.for


      subroutine prj(it,x,y,z)
      common/gfmt/t(4,4),tt(4,4),tr(4,4),dpr1(3),itpprj
      dimension dpr(3)
C**   print 10,it,x,y,z
C##10    format(' **prj param.:',i5,3f10.3)
C..... we use right coord. system.
      eps=1.e-8
         dpr1(1)=x
         dpr1(2)=y
         dpr1(3)=z
         itpprj=it
C.....normalization of "vector of direct. of proj.".
      d=sqrt(x*x+y*y+z*z)
      if(abs(d).le.eps) goto 1
      dpr(1)=x/d
      dpr(2)=y/d
      dpr(3)=z/d
C   ====================================================================
C     rotate the view plane so that "vector x,y,z" lies along the z-axis
C      (and the view plane coinsides with xy-plane).
C   ====================================================================
      s=sqrt(dpr(1)*dpr(1)+dpr(3)*dpr(3))
C.....test: are "x" and "z" both equal to zero
      if(s.gt.eps) goto 3
C
C     "s" equals zero.
      call hcinit(t)
      goto 4
C
3     continue
C     "s" - non equal zero.
C.....rotate the "dpr vector" about the y-axis into the yz-plane.
      call strot3(2,dpr(3)/s,dpr(1)/s,t)
C++   print 55,((t(i,j),j=1,4),i=1,4)
C##55    format(' t(4,4):'/(4f11.3))
C.....rotate about the x-axis so the "dpr vector" lies along the z-axis.
4     call strot3(1,s,-dpr(2),tr)
C++   print 55,((tr(i,j),j=1,4),i=1,4)
      call mxmult(t,tr)
C++   print 55,((t(i,j),j=1,4),i=1,4)
C
C.....test: parallel or perspective projection
      if(it.eq.0) goto 5
C.....the matrix for persp.("on orthogonal plane") projection.
C    we must do:  call strow3(0.,0.,-1./d,tr); call mxmult(t,tr);
C                call sclg3d(0.,0.,-1.,0.,tr); call mxmult(t,tr).
C    but more efficiently:
      call hcinit(tr)
      tr(3,4)=-1./d
      tr(3,3)=-1.
C++   print 55,((tr(i,j),j=1,4),i=1,4)
      call mxmult(t,tr)
C++   print 55,((t(i,j),j=1,4),i=1,4)
      return
5     continue
C.....the matrix for parallel (axonometric) projection.
      return
1     continue
      call hcinit(t)
C##   print 2
C##2     format('   ***erroneous "x,y,z"')
      return
      end


module Mod_LogOperations
   use typre
   use Mod_supm_MatrixVector
   implicit none

   !-----------------------------
   !This module contains operation used by de Logarithm Conformation Reformulation Model
   !-----------------------------

contains

   subroutine sup_ComputeExponential(ndime,auxtens,Vector,Expo_Vect,Expo_Matrix)
   !Compute Exp(Psi), where Psi is a tensor in voigt notation (i.e. a vector)

      implicit none
      integer(ip) :: auxtens,ndime
      real(rp)  :: D(ndime), V(ndime,ndime), V_inv(ndime,ndime)
      real(rp)  :: Exp1(ndime,ndime),D_Mat(ndime,ndime)
      real(rp)  :: Expo_Matrix(ndime,ndime), Expo_Vect(auxtens)
      real(rp)  :: Vector(auxtens), Matrix(ndime,ndime)
      real(rp)  :: ExpoDiagMatrix(ndime,ndime), ExpoD(ndime)
      real(rp)  ::  Sol1(ndime,ndime), Sol(ndime,ndime)
      integer   :: info,lwork,i
      real(rp)  :: work(ndime*4)
      lwork = 4*ndime

      call sup_SigmaMatrix(ndime,auxtens,Vector,Matrix)

      V=Matrix
      CALL DSYEV( 'Vectors', 'Upper', ndime, V, ndime, D, work, lwork, info)

      V_inv=transpose(V) ! V^-1 = V^T because of orthogonality

      ExpoD=exp(D)
      call ConvertVectorToDiagMatrix(ndime,ExpoD,ExpoDiagMatrix)

      Exp1=matmul(V,ExpoDiagMatrix)
      Expo_Matrix=matmul(Exp1,V_inv)

      call ConvertSigmaMatrixToVector(ndime,auxtens,Expo_Matrix,Expo_Vect)

   end subroutine

   subroutine sup_LogarithmicTransformation(ndime,ntens,auxL,sigma,psi)
   !Compute Log(auxL*S+I)

      implicit none
      real(rp) :: sigma(ntens),psi(ntens),auxL_inv,auxL
      real(rp) :: Sigma_Matrix(ndime,ndime), V(ndime,ndime),D(ndime),V_inv(ndime,ndime)
      real(rp) :: logD(ndime),LogDMatrix(ndime,ndime), Log_Matrix(ndime,ndime),tau(ntens)
      integer(ip) :: ntens,i,j,ndime
      integer   :: info,lwork
      real(rp)  :: work(ndime*4)
      lwork = 4*ndime
      call sup_ComputeConformationTensor(ndime,ntens,auxL,sigma,tau)

      call sup_SigmaMatrix(ndime,ntens,tau,Sigma_Matrix)
      V=Sigma_Matrix
      CALL DSYEV( 'Vectors', 'Upper', ndime, V, ndime, D, work, lwork, info)

      V_inv=transpose(V) ! V^-1 = V^T because of orthogonality

      LogD=log(D)
      call ConvertVectorToDiagMatrix(ndime,LogD,LogDMatrix)

      Log_Matrix=matmul(matmul(V,LogDMatrix),V_inv)

      call ConvertSigmaMatrixToVector(ndime,ntens,Log_Matrix,psi)

   end subroutine

   subroutine sup_ComputeConformationTensor(ndime,auxtens,auxL,sigma,tau)
      !Compute tau=auxL*S+I

      implicit none
      integer(ip) :: i,j, auxtens,ndime
      real(rp) :: sigma(auxtens), tau(auxtens),auxL,auxL_inv

      auxL_inv=1.0_rp/auxL
      tau=0.0_rp
      tau= auxL_inv*sigma
      tau(1:ndime)=1.0_rp + tau(1:ndime)

   end subroutine

   subroutine sup_ComputeEigenVectors(ndime,Matrix,eigenvectors,eigenvalues)
      implicit none
      real(rp)             :: Matrix(ndime,ndime),eigenvectors(ndime,ndime), eigenvalues(ndime)
      real(rp)             :: R(ndime,ndime), D(ndime)
      integer              :: info,lwork,ndime
      real(rp)             :: work(ndime*4)

      lwork = 4*ndime
      R=Matrix
      CALL DSYEV( 'Vectors', 'Upper', ndime, R, ndime, D, work, lwork, info)
      Eigenvectors=R
      Eigenvalues=D
   end subroutine

end module