!------------------------------------------------------------------------------!
!Compute energy spectrum from computed data produced by euler2d_MPI.f90
!To run: gfortran -o aa spec2d.f90
!------------------------------------------------------------------------------!
!Omer San
!Oklahoma State University, Stillwater
!CFDLab.org, cfdlab.osu@gmail.com
!Updated: June 18, 2016
!------------------------------------------------------------------------------!

program spec2d
implicit none
integer, parameter::nsnap_s=1 !snapshot id in order to process
integer, parameter::nsnap_e=5 !snapshot id in order to process
integer, parameter::np=12  !number of processor (nodes x ppn)
integer :: nx,ny  !global number of data point in x (even, resolution)
!integer, parameter::ny=nx  	!global number of data point in y (local ny=ny/np)
!real*8 ::u(0:nx,0:ny)
!real*8 ::v(0:nx,0:ny)
!real*8 ::rh(0:nx,0:ny)
!real*8 ::w(0:nx,0:ny)
!real*8 ::x(0:nx,0:ny)
!real*8 ::y(0:nx,0:ny)
real*8,dimension(:,:),allocatable :: u,v,w,rh,p,x,y
integer:: i,j,myid,jj,ifile,myid2,nyl,ipr
character(80):: charID,snapID,filename,fi2
real*8 :: dx,dy
real*8, dimension (:), allocatable :: aa,bb

nx = 256
ny = nx

ipr = 0

allocate(u(0:nx,0:ny))
allocate(v(0:nx,0:ny))
allocate(w(0:nx,0:ny))
allocate(rh(0:nx,0:ny))
allocate(p(0:nx,0:ny))
allocate(x(0:nx,0:ny))
allocate(y(0:nx,0:ny))

do ifile=nsnap_s,nsnap_e

jj = 0

do myid = 0,np-1

write(charID,'(i5)') myid       !index for each processor
write(snapID,'(i5)') ifile      !index for time snapshot

! Read data file
fi2= "load_"// trim(adjustl(charID)) // '.dat'
open(unit=19, file=fi2)
read(19,*)myid2,nyl
close(19)

! Read data file

! Define the file name
filename = "vel_"// trim(adjustl(snapID)) //'_' // trim(adjustl(charID)) // '.plt'

! Open the file and start reading the data
open(unit=19, file=filename)
read(19,*)
read(19,*)
read(19,*)
! Read velocity  data
do j = 0, nyl
do i = 0, nx
  	read(19,*) x(i,j+jj), y(i,j+jj), u(i,j+jj),v(i,j+jj)
end do
end do
close(19)

if (ipr.eq.1) then !defined pressure
! Define the file name
filename = "pressure_"// trim(adjustl(snapID)) //'_' // trim(adjustl(charID)) // '.plt'

! Open the file and start reading the data
open(unit=19, file=filename)
read(19,*)
read(19,*)
read(19,*)
! Read density  data
do j = 0, nyl
do i = 0, nx
  	read(19,*) x(i,j+jj), y(i,j+jj), p(i,j+jj)
end do
end do
close(19)

else

do j = 0, nyl
do i = 0, nx
  	p(i,j+jj) = 0.0d0
end do
end do

end if

! Define the file name
filename = "density_"// trim(adjustl(snapID)) //'_' // trim(adjustl(charID)) // '.plt'

! Open the file and start reading the data
open(unit=19, file=filename)
read(19,*)
read(19,*)
read(19,*)
! Read density  data
do j = 0, nyl
do i = 0, nx
  	read(19,*) x(i,j+jj), y(i,j+jj), rh(i,j+jj)
end do
end do
close(19)

jj = nyl+jj

end do

! writing density field at cell centers:
! Define the file name
filename = "rho_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "rho"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1, ' f=point'
do j=0,ny
do i=0,nx
write(19,*)x(i,j),y(i,j),rh(i,j)
end do
end do
close(19)

!constant dx and dy
dx = x(2,1)-x(1,1)
dy = y(1,2)-y(1,1)

! compute vorticity
! v_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = v(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	w(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = u(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	w(i,j) = w(i,j) - bb(j)
	end do
end do
deallocate(aa,bb)

! writing vorticity field at cell centers:
! Define the file name
filename = "vorticity_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "Vorticity"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1, ' f=point'
do j=0,ny
do i=0,nx
write(19,*)x(i,j),y(i,j),w(i,j)
end do
end do
close(19)

!compute density weighted spectrum from velocity and density fields
call spectrum_den_2d(nx,ny,rh,u,v,ifile)

!compute spectrum from velocity field
call spectrum2d(nx,ny,u,v,ifile)

!compute structure function
call strfun2d(nx,ny,u,v,ifile)

!compute pdf distributions
!call pdfdist2d(nx,ny,rh,u,v,w,ifile)

!compute energy transfer from velocity field
!call energy_basic_2d(nx,ny,dx,dy,u,v,ifile)

!compute energy transfer for compressible flows
!call energy_ave_2d(nx,ny,dx,dy,u,v,ifile)

!compute energy transfer for compressible flows
!call energy_all_2d(nx,ny,dx,dy,u,v,rh,p,ifile)

!old post-processing routines:

!compute spectrum from vorticity field
!call spectrum2d_vorticity(nx,ny,w,ifile)
!appropriate one
!call spectrum2d_vorticity_new(nx,ny,w,ifile)
!compute spectrum from velocity field
!call spec(nx,ny,u,v,ifile)
!compute spectrum from vorticity field
!call specw(nx,ny,w,ifile)
!compute spectrum from vorticity data (the one we used before)
!call specnew(nx,ny,w,ifile)

end do

end

!-----------------------------------------------------------------!
!Compute energy transfer from velocity field
!-----------------------------------------------------------------!
subroutine energy_basic_2d(nx,ny,dx,dy,u,v,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::dx,dy
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,p,np
real*8 ::kx(0:nx),ky(0:ny)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,data4d,ae
real*8,dimension(:,:),allocatable::ee
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp,kr
character(80):: snapID,filename
real*8,dimension (:), allocatable :: aa,bb
real*8,dimension(:,:),allocatable :: ux,uy,vx,vy,ax,ay

!compute convective terms:
allocate(ux(0:nx,0:ny))
allocate(uy(0:nx,0:ny))

! u_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = u(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	ux(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = u(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	uy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ax(0:nx,0:ny))

do i=0,nx
do j=0,ny
ax(i,j) = u(i,j)*ux(i,j) + v(i,j)*uy(i,j)
end do
end do

deallocate(ux,uy)

allocate(vx(0:nx,0:ny))
allocate(vy(0:nx,0:ny))

! v_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = v(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	vx(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! v_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = v(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	vy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ay(0:nx,0:ny))

do i=0,nx
do j=0,ny
ay(i,j) = u(i,j)*vx(i,j) + v(i,j)*vy(i,j)
end do
end do

deallocate(vx,vy)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))
allocate(data3d(2*nx*ny))
allocate(data4d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)
data2d(p+1)=0.0d0
data3d(p)  =ax(i,j)
data3d(p+1)=0.0d0
data4d(p)  =ay(i,j)
data4d(p+1)=0.0d0
p=p+2
end do
end do

deallocate(ax,ay)

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)
call fourn(data4d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
data4d(p)=data4d(p)*temp
end do

!TE(k)
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)= data1d(p)*data3d(p) + data1d(p+1)*data3d(p+1) &
       + data2d(p)*data4d(p) + data2d(p+1)*data4d(p+1)
p=p+2
end do
end do

deallocate(data1d,data2d,data3d,data4d)

! energy flux
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!summation!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.gt.dfloat(p)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

! Define the file name
filename = "eflux_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-ae(p)
end do
close(802)

deallocate(ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute energy transfer from velocity field
!-----------------------------------------------------------------!
subroutine energy_ave_2d(nx,ny,dx,dy,u,v,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::dx,dy
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,p,pp,np
real*8 ::kx(0:nx),ky(0:ny)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,data4d,ae,as
real*8,dimension(:,:),allocatable::ee
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp,kr
character(80):: snapID,filename
real*8,dimension (:), allocatable :: aa,bb
real*8,dimension(:,:),allocatable :: ux,uy,vx,vy,ax,ay

!compute convective terms:
allocate(ux(0:nx,0:ny))
allocate(uy(0:nx,0:ny))

! u_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = u(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	ux(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = u(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	uy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ax(0:nx,0:ny))

do i=0,nx
do j=0,ny
ax(i,j) = u(i,j)*ux(i,j) + v(i,j)*uy(i,j)
end do
end do

deallocate(ux,uy)

allocate(vx(0:nx,0:ny))
allocate(vy(0:nx,0:ny))

! v_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = v(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	vx(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! v_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = v(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	vy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ay(0:nx,0:ny))

do i=0,nx
do j=0,ny
ay(i,j) = u(i,j)*vx(i,j) + v(i,j)*vy(i,j)
end do
end do

deallocate(vx,vy)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))
allocate(data3d(2*nx*ny))
allocate(data4d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)
data2d(p+1)=0.0d0
data3d(p)  =ax(i,j)
data3d(p+1)=0.0d0
data4d(p)  =ay(i,j)
data4d(p+1)=0.0d0
p=p+2
end do
end do

deallocate(ax,ay)

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)
call fourn(data4d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
data4d(p)=data4d(p)*temp
end do

!TE(k)
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)= data1d(p)*data3d(p) + data1d(p+1)*data3d(p+1) &
       + data2d(p)*data4d(p) + data2d(p+1)*data4d(p+1)
p=p+2
end do
end do

deallocate(data1d,data2d,data3d,data4d)

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

allocate(as(np))

!summation!

do p=1,np
as(p) = 0.0d0

	do pp=p,np
	as(p) = as(p) + ae(pp)
    end do

end do

! Define the file name
filename = "eflux_ave_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-as(p)
end do
close(802)

deallocate(ee,ae,as)

return
end

!-----------------------------------------------------------------!
!Compute energy transfer from velocity, density, pressure fields
!Han Liu, Z Xiao PRE 2016
!-----------------------------------------------------------------!
subroutine energy_all_2d(nx,ny,dx,dy,u,v,rh,pr,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::dx,dy
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
real*8 ::rh(0:nx,0:ny)
real*8 ::pr(0:nx,0:ny)
integer::i,j,p,pp,np
real*8 ::kx(0:nx),ky(0:ny)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,data4d,ae,as,at
real*8,dimension(:,:),allocatable::ee
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp,kr
character(80):: snapID,filename
real*8,dimension (:), allocatable :: aa,bb
real*8,dimension(:,:),allocatable :: ux,uy,vx,vy,ax,ay

!--------------------------------!
!compute advective terms:
!--------------------------------!
allocate(ux(0:nx,0:ny))
allocate(uy(0:nx,0:ny))

! u_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = u(i,j)*dsqrt(dabs(rh(i,j)))
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	ux(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = u(i,j)*dsqrt(dabs(rh(i,j)))
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	uy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ax(0:nx,0:ny))

do i=0,nx
do j=0,ny
ax(i,j) = u(i,j)*ux(i,j) + v(i,j)*uy(i,j)
end do
end do

deallocate(ux,uy)

allocate(vx(0:nx,0:ny))
allocate(vy(0:nx,0:ny))

! v_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = v(i,j)*dsqrt(dabs(rh(i,j)))
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	vx(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! v_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = v(i,j)*dsqrt(dabs(rh(i,j)))
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	vy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ay(0:nx,0:ny))

do i=0,nx
do j=0,ny
ay(i,j) = u(i,j)*vx(i,j) + v(i,j)*vy(i,j)
end do
end do

deallocate(vx,vy)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))
allocate(data3d(2*nx*ny))
allocate(data4d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)*dsqrt(dabs(rh(i,j)))
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)*dsqrt(dabs(rh(i,j)))
data2d(p+1)=0.0d0
data3d(p)  =ax(i,j)
data3d(p+1)=0.0d0
data4d(p)  =ay(i,j)
data4d(p+1)=0.0d0
p=p+2
end do
end do

deallocate(ax,ay)

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)
call fourn(data4d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
data4d(p)=data4d(p)*temp
end do

!TE(k)
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)= data1d(p)*data3d(p) + data1d(p+1)*data3d(p+1) &
       + data2d(p)*data4d(p) + data2d(p+1)*data4d(p+1)
p=p+2
end do
end do

deallocate(data1d,data2d,data3d,data4d)

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))
allocate(at(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

allocate(as(np))

!summation!

do p=1,np
as(p) = 0.0d0

	do pp=p,np
	as(p) = as(p) + ae(pp)
    end do

at(p) = as(p)
end do

! Define the file name
filename = "eflux_ave_adv_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-as(p)
end do
close(802)

deallocate(ee,ae,as)

!-------------------------------------!
!compute dilatational terms:
!-------------------------------------!
allocate(ux(0:nx,0:ny))
allocate(vy(0:nx,0:ny))

! u_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = u(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	ux(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! v_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = v(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	vy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ax(0:nx,0:ny))

do i=0,nx
do j=0,ny
ax(i,j) = 0.5d0*u(i,j)*dsqrt(dabs(rh(i,j)))*(ux(i,j) + vy(i,j))
end do
end do

allocate(ay(0:nx,0:ny))

do i=0,nx
do j=0,ny
ay(i,j) = 0.5d0*v(i,j)*dsqrt(dabs(rh(i,j)))*(ux(i,j) + vy(i,j))
end do
end do

deallocate(ux,vy)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))
allocate(data3d(2*nx*ny))
allocate(data4d(2*nx*ny))

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)*dsqrt(dabs(rh(i,j)))
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)*dsqrt(dabs(rh(i,j)))
data2d(p+1)=0.0d0
data3d(p)  =ax(i,j)
data3d(p+1)=0.0d0
data4d(p)  =ay(i,j)
data4d(p+1)=0.0d0
p=p+2
end do
end do

deallocate(ax,ay)

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)
call fourn(data4d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
data4d(p)=data4d(p)*temp
end do

!TE(k)
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)= data1d(p)*data3d(p) + data1d(p+1)*data3d(p+1) &
       + data2d(p)*data4d(p) + data2d(p+1)*data4d(p+1)
p=p+2
end do
end do

deallocate(data1d,data2d,data3d,data4d)

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

allocate(as(np))

!summation!

do p=1,np
as(p) = 0.0d0

	do pp=p,np
	as(p) = as(p) + ae(pp)
    end do

at(p) = at(p) + as(p)
end do

! Define the file name
filename = "eflux_ave_dil_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-as(p)
end do
close(802)

deallocate(ee,ae,as)

!----------------------------------!
!compute pressure terms:
!----------------------------------!
allocate(ux(0:nx,0:ny))
allocate(uy(0:nx,0:ny))

! u_x
allocate(aa(0:nx),bb(0:nx))
do j=0,ny
	do i=0,nx
	aa(i) = pr(i,j)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	ux(i,j) = bb(i)
	end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
	do j=0,ny
	aa(j) = pr(i,j)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	uy(i,j) = bb(j)
	end do
end do
deallocate(aa,bb)

allocate(ax(0:nx,0:ny))

do i=0,nx
do j=0,ny
ax(i,j) = 0.5d0*ux(i,j)/dsqrt(dabs(rh(i,j)))
end do
end do

allocate(ay(0:nx,0:ny))

do i=0,nx
do j=0,ny
ay(i,j) = 0.5d0*uy(i,j)/dsqrt(dabs(rh(i,j)))
end do
end do

deallocate(ux,uy)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))
allocate(data3d(2*nx*ny))
allocate(data4d(2*nx*ny))

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)*dsqrt(dabs(rh(i,j)))
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)*dsqrt(dabs(rh(i,j)))
data2d(p+1)=0.0d0
data3d(p)  =ax(i,j)
data3d(p+1)=0.0d0
data4d(p)  =ay(i,j)
data4d(p+1)=0.0d0
p=p+2
end do
end do

deallocate(ax,ay)

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)
call fourn(data3d,nn,ndim,isign)
call fourn(data4d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
data3d(p)=data3d(p)*temp
data4d(p)=data4d(p)*temp
end do

!TE(k)
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)= data1d(p)*data3d(p) + data1d(p+1)*data3d(p+1) &
       + data2d(p)*data4d(p) + data2d(p+1)*data4d(p+1)
p=p+2
end do
end do

deallocate(data1d,data2d,data3d,data4d)

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

allocate(as(np))

!summation!

do p=1,np
as(p) = 0.0d0

	do pp=p,np
	as(p) = as(p) + ae(pp)
    end do

at(p) = at(p) + as(p)
end do

! Define the file name
filename = "eflux_ave_pre_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-as(p)
end do
close(802)

! Define the file name
filename = "eflux_ave_tot_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","P(k)"'
do p=1,np
write(802,*)dfloat(p),-at(p)
end do
close(802)

deallocate(ee,ae,as,at)

return
end

!-----------------------------------------------------------------!
!Compute density weighted spectrum from 2D velocity and density fields
!-----------------------------------------------------------------!
subroutine spectrum_den_2d(nx,ny,rh,u,v,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::rh(0:nx,0:ny)
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,p,np
real*8 ::kx(0:nx),ky(0:ny)
real*8,dimension(:),allocatable:: data1d,data2d,ae
real*8,dimension(:,:),allocatable::ee
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp,kr
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =dsqrt(dabs(rh(i,j)))*u(i,j)
data1d(p+1)=0.0d0
data2d(p)  =dsqrt(dabs(rh(i,j)))*v(i,j)
data2d(p+1)=0.0d0
p=p+2
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
end do

!Density weighted Energy density
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)=0.5d0*(data1d(p)*data1d(p) + data1d(p+1)*data1d(p+1) &
              +data2d(p)*data2d(p) + data2d(p+1)*data2d(p+1))
p=p+2
end do
end do

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

! Define the file name
filename = "spectrum_den_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","E(k)"'
do p=1,np
write(802,*)dfloat(p),ae(p)
end do
close(802)

open(15,file="spectrum_k3.plt")
write(15,*) 'variables ="k","E(k)"'
write(15,*)2.0d0, 1.0d0
write(15,*)200.0d0, 1.0d-6
close(15)

deallocate(data1d,data2d,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute spectrum from 2D velocity field by definition of Kida
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spectrum2d(nx,ny,u,v,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,p,np
real*8 ::kx(0:nx),ky(0:ny)
real*8,dimension(:),allocatable:: data1d,data2d,ae
real*8,dimension(:,:),allocatable::ee
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp,kr
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))
allocate(data2d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do

!finding fourier coefficients of u and v
!invese fourier transform
p=1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =u(i,j)
data1d(p+1)=0.0d0
data2d(p)  =v(i,j)
data2d(p+1)=0.0d0
p=p+2
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
data2d(p)=data2d(p)*temp
end do

!Energy density
allocate(ee(0:nx-1,0:ny-1))

p=1
do j=0,ny-1
do i=0,nx-1
ee(i,j)=0.5d0*(data1d(p)*data1d(p) + data1d(p+1)*data1d(p+1) &
              +data2d(p)*data2d(p) + data2d(p+1)*data2d(p+1))
p=p+2
end do
end do

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(ae(np))

!averaging!
do p=1,np
	ae(p)=0.0d0
	do j=0,ny-1
	do i=0,nx-1
    	kr=dsqrt(kx(i)*kx(i)+ky(j)*ky(j))
        if (kr.ge.(dfloat(p)-0.5d0).and.kr.lt.(dfloat(p)+0.5d0)) then
		ae(p)=ae(p)+ee(i,j)
		end if
	end do
    end do
end do

! Define the file name
filename = "spectrum_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="k","E(k)"'
do p=1,np
write(802,*)dfloat(p),ae(p)
end do
close(802)

open(15,file="spectrum_k3.plt")
write(15,*) 'variables ="k","E(k)"'
write(15,*)2.0d0, 1.0d0
write(15,*)200.0d0, 1.0d-6
close(15)

deallocate(data1d,data2d,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute structure functions from 2D velocity field by definition
!Boffetta, Musacchio, PRE 2010
!Kramer et al., PRE 2011
!-----------------------------------------------------------------!
subroutine strfun2d(nx,ny,u,v,ifile)
implicit none
integer::nx,ny,ifile
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,ii,jj,ir,jr
real*8 ::dlu2(1:nx/2),dtv2(1:nx/2),dlu3(1:nx/2),dtv3(1:nx/2)
real*8 ::dlv2(1:ny/2),dtu2(1:ny/2),dlv3(1:ny/2),dtu3(1:ny/2)
real*8 ::dl2(1:ny/2),dt2(1:ny/2),dl3(1:ny/2),dt3(1:ny/2)
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

do ii=1,nx/2

	dlu2(ii) = 0.0d0
    dtv2(ii) = 0.0d0

    dlu3(ii) = 0.0d0
    dtv3(ii) = 0.0d0

	do j=1,ny
	do i=1,nx

    	if (i+ii.ge.nx) then
        ir = ii-nx
        else
        ir = ii
        end if

		dlu2(ii)=dlu2(ii)+(dabs(u(i+ir,j)-u(i,j)))**2 !longitudinal
        dtv2(ii)=dtv2(ii)+(dabs(v(i+ir,j)-v(i,j)))**2 !transverse

		dlu3(ii)=dlu3(ii)+(dabs(u(i+ir,j)-u(i,j)))**3 !longitudinal
        dtv3(ii)=dtv3(ii)+(dabs(v(i+ir,j)-v(i,j)))**3 !transverse

	end do
	end do
    	dlu2(ii) = dlu2(ii)/dfloat(nx*ny)
        dtv2(ii) = dtv2(ii)/dfloat(nx*ny)

        dlu3(ii) = dlu3(ii)/dfloat(nx*ny)
        dtv3(ii) = dtv3(ii)/dfloat(nx*ny)
end do

do jj=1,ny/2

  	dlv2(jj) = 0.0d0
  	dtu2(jj) = 0.0d0

    dlv3(jj) = 0.0d0
  	dtu3(jj) = 0.0d0

	do j=1,ny
	do i=1,nx

    	if (j+jj.ge.ny) then
        jr = jj-ny
        else
        jr = jj
        end if

		dlv2(jj)=dlv2(jj)+(dabs(v(i,j+jr)-v(i,j)))**2 !longitudinal
        dtu2(jj)=dtu2(jj)+(dabs(u(i,j+jr)-u(i,j)))**2 !transverse

		dlv3(jj)=dlv3(jj)+(dabs(v(i,j+jr)-v(i,j)))**3 !longitudinal
        dtu3(jj)=dtu3(jj)+(dabs(u(i,j+jr)-u(i,j)))**3 !transverse

	end do
	end do

        dlv2(jj) = dlv2(jj)/dfloat(nx*ny)
        dtu2(jj) = dtu2(jj)/dfloat(nx*ny)

        dlv3(jj) = dlv3(jj)/dfloat(nx*ny)
        dtu3(jj) = dtu3(jj)/dfloat(nx*ny)

        dl2(jj) = 0.5d0*(dlv2(jj) + dlu2(jj))
        dt2(jj) = 0.5d0*(dtv2(jj) + dtu2(jj))

        dl3(jj) = 0.5d0*(dlv3(jj) + dlu3(jj))
        dt3(jj) = 0.5d0*(dtv3(jj) + dtu3(jj))
end do

! Define the file name
filename = "str_long_2nd_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="r","F(r)"'
do jj=1,ny/2
write(802,*)dfloat(jj)/dfloat(ny),dl2(jj)
end do
close(802)

! Define the file name
filename = "str_tran_2nd_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="r","F(r)"'
do jj=1,ny/2
write(802,*)dfloat(jj)/dfloat(ny),dt2(jj)
end do
close(802)

! Define the file name
filename = "str_long_3rd_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="r","F(r)"'
do jj=1,ny/2
write(802,*)dfloat(jj)/dfloat(ny),dl3(jj)
end do
close(802)

! Define the file name
filename = "str_tran_3rd_"// trim(adjustl(snapID)) //'.plt'

open(unit=802, file=filename)
write(802,*)'variables ="r","F(r)"'
do jj=1,ny/2
write(802,*)dfloat(jj)/dfloat(ny),dt3(jj)
end do
close(802)

return
end

!-----------------------------------------------------------------!
!Spectrum from vorticity data
!-----------------------------------------------------------------!
subroutine spectrum2d_vorticity(nx,ny,w,ifile)
implicit none
integer ::nx,ny,ifile
double precision::w(0:nx,0:ny)
double precision::pi,temp
integer::i,j,p,np,ic
double precision::kx(0:nx),ky(0:ny),kr
double precision,parameter:: tiny=1.0d-10
double precision,dimension(:),allocatable:: data1d,en
double precision,dimension(:,:),allocatable::es
integer,parameter::ndim=2
integer::nn(ndim),isign
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))

pi = 4.0d0*datan(1.0d0)

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of w
!invese fourier transform
!find the vorticity in Fourier space
p=1
do j=0,ny-1
do i=0,nx-1
	data1d(p)   =  w(i,j)
	data1d(p+1) =  0.0d0
p = p + 2
end do
end do

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
end do

!inverse fourier transform
isign= -1
call fourn(data1d,nn,ndim,isign)

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do
kx(0) = tiny

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do
ky(0) = tiny

!Energy spectrum (for all wavenumbers), amplitude
allocate(es(0:nx-1,0:ny-1))
p=1
do j=0,ny-1
do i=0,nx-1
kr = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
es(i,j) = pi*(data1d(p)*data1d(p) + data1d(p+1)*data1d(p+1))/kr
p = p + 2
end do
end do

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(en(np))

do p=1,np
en(p) = 0.0d0
ic = 0
do j=0,ny-1
do i=0,nx-1
	kr = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
    if(kr.ge.(dfloat(p)-0.5d0).and.kr.le.(dfloat(p)+0.5d0)) then
    ic = ic + 1
    en(p) = en(p) + es(i,j)
    end if
end do
end do
en(p) = en(p) / dfloat(ic)
end do

! Define the file name
filename = "spectrum_vorticity_"// trim(adjustl(snapID)) //'.plt'

open(unit=902, file=filename)
write(902,*)'variables ="k","E(k)"'
do p=1,np
write(902,*)dfloat(p),en(p)
end do
close(902)

deallocate(data1d,es,en)

return
end

!-----------------------------------------------------------------!
!Spectrum from vorticity data
!-----------------------------------------------------------------!
subroutine spectrum2d_vorticity_new(nx,ny,w,ifile)
implicit none
integer ::nx,ny,ifile
double precision::w(0:nx,0:ny)
double precision::temp
integer::i,j,p,np,ic
double precision::kx(0:nx),ky(0:ny),kr
double precision,parameter:: tiny=1.0d-10
double precision,dimension(:),allocatable:: data1d,en
double precision,dimension(:,:),allocatable::es
integer,parameter::ndim=2
integer::nn(ndim),isign
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of w
!invese fourier transform
!find the vorticity in Fourier space
p=1
do j=0,ny-1
do i=0,nx-1
	data1d(p)   =  w(i,j)
	data1d(p+1) =  0.0d0
p = p + 2
end do
end do

temp = 1.0d0/dfloat(nx*ny)

!normalize
do p=1,2*nx*ny
data1d(p)=data1d(p)*temp
end do

!inverse fourier transform
isign= -1
call fourn(data1d,nn,ndim,isign)

!wave numbers (sequence is important)
p=0
do i=0,nx/2
kx(i) = dfloat(p)
p=p+1
end do
p=-nx/2+1
do i=nx/2+1,nx-1
kx(i) = dfloat(p)
p=p+1
end do
kx(0) = tiny

p=0
do j=0,ny/2
ky(j) = dfloat(p)
p=p+1
end do
p=-ny/2+1
do j=ny/2+1,ny-1
ky(j) = dfloat(p)
p=p+1
end do
ky(0) = tiny

!Energy spectrum (for all wavenumbers), amplitude
allocate(es(0:nx-1,0:ny-1))
p=1
do j=0,ny-1
do i=0,nx-1
kr = kx(i)*kx(i) + ky(j)*ky(j)
es(i,j) = 0.5d0*(data1d(p)*data1d(p) + data1d(p+1)*data1d(p+1))/kr
p = p + 2
end do
end do

! band-avaraged energy spectrum
np = nint(dsqrt((kx(nx/2))**2 + (ky(ny/2))**2))

allocate(en(np))

do p=1,np
en(p) = 0.0d0
ic = 0
do j=0,ny-1
do i=0,nx-1
	kr = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
    if(kr.ge.(dfloat(p)-0.5d0).and.kr.le.(dfloat(p)+0.5d0)) then
    ic = ic + 1
    en(p) = en(p) + es(i,j)
    end if
end do
end do
en(p) = en(p)
end do

! Define the file name
filename = "spectrum_vorticity_new_"// trim(adjustl(snapID)) //'.plt'

open(unit=902, file=filename)
write(902,*)'variables ="k","E(k)"'
do p=1,np
write(902,*)dfloat(p),en(p)
end do
close(902)

deallocate(data1d,es,en)

return
end

!-----------------------------------------------------------------!
!Compute spectrum by definition of Kida
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spec_kida(nx,ny,u,v,ifile)
implicit none
integer::nx,ny,n,ifile
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,k,k1,k2
real*8,parameter:: tiny=1.0d-10,tiny2=1.0d-14
real*8,dimension(:),allocatable:: data1d,data2d,u1,u2,kk,ee,ae
integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::temp
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny),data2d(2*nx*ny),u1(nx*ny),u2(nx*ny),kk(nx*ny),ee(nx*ny))

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of u and v
!invese fourier transform
k=1
do j=1,ny
do i=1,nx
data1d(k)  =u(i,j)
data1d(k+1)=0.0d0
data2d(k)  =v(i,j)
data2d(k+1)=0.0d0
k=k+2
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)

temp = 1.0d0/dfloat(nx*ny)

do j=1,2*nx*ny
data1d(j)=data1d(j)*temp
data2d(j)=data2d(j)*temp
end do

! absolute values for fourier coefficients, squared
k=1
do j=1,nx*ny
u1(j)=data1d(k)*data1d(k) + data1d(k+1)*data1d(k+1)
u2(j)=data2d(k)*data2d(k) + data2d(k+1)*data2d(k+1)
ee(j)=0.5d0*(u1(j)+u2(j))
k=k+2
end do

! wave numbers, real number absolute
k=1
do k2 = 0,ny/2
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1= -nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

do k2 =-ny/2+1,-1
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1=-nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

! avaraged energy spectrum
n=int(sqrt(float(nx*ny))*sqrt(2.0)/2.0 )-1
allocate(ae(n))

!averaging!
do i=1,n
	ae(i)=0.0d0
	do j=1,nx*ny
        if (kk(j).ge.(dfloat(i)-0.5d0).and.kk(j).lt.(dfloat(i)+0.5d0)) then
		ae(i)=ae(i)+ee(j)
		end if
	end do
end do

! Define the file name
filename = "spectrum_"// trim(adjustl(snapID)) //'.plt'

open(unit=800, file=filename)
write(800,*)'variables ="k","E(k)"'
do i=1,n
write(800,*)dfloat(i),ae(i)
end do
close(800)

open(15,file="spectrum_k3.plt")
write(15,*) 'variables ="k","E(k)"'
write(15,*)2.0d0, 1.0d0
write(15,*)200.0d0, 1.0d-6
close(15)

deallocate(data1d,data2d,u1,u2,kk,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute spectrum
!-----------------------------------------------------------------!
subroutine spec(nx,ny,u,v,ifile)
implicit none
integer::nx,ny,n,ic,ifile
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
integer::i,j,k,k1,k2

real*8,parameter:: tiny=1.0d-10,tiny2=1.0d-14
real*8,dimension(:),allocatable:: data1d,data2d,u1,u2,kk,ee,ae

integer,parameter::ndim=2
integer::nn(ndim),isign
real*8 ::pi
character(80):: snapID,filename

pi = 4.0d0*datan(1.0d0)

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny),data2d(2*nx*ny),u1(nx*ny),u2(nx*ny),kk(nx*ny),ee(nx*ny))

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of u and v
!invese fourier transform
k=1
do j=1,ny
do i=1,nx
data1d(k)  =u(i,j)
data1d(k+1)=0.0d0
data2d(k)  =v(i,j)
data2d(k+1)=0.0d0
k=k+2
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)
call fourn(data2d,nn,ndim,isign)

do j=1,2*nx*ny
data1d(j)=data1d(j) /dfloat(nx*ny)
data2d(j)=data2d(j) /dfloat(nx*ny)
end do

! absolute values for fourier coefficients
k=1
do j=1,nx*ny
u1(j)=data1d(k)*data1d(k) + data1d(k+1)*data1d(k+1)
u2(j)=data2d(k)*data2d(k) + data2d(k+1)*data2d(k+1)
k=k+2
end do

! wave numbers
k=1
do k2 = 0,ny/2
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1= -nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

do k2 =-ny/2+1,-1
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1=-nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

! energy spectrum

do j=1,nx*ny
	ee(j)=0.5d0*(u1(j)+u2(j))  !u1 and u2 are squared data
end do

! Define the file name
filename = "spectrum_scattered_"// trim(adjustl(snapID)) //'.plt'

open(unit=700, file=filename)
write(700,*)'variables ="k","E"'
do j=1,nx*ny
write(700,*)kk(j),ee(j)
end do
close(700)

! avaraged energy spectrum
n=int(sqrt(float(nx*ny))*sqrt(2.0)/2.0 )-1
allocate(ae(n))

!averaging!
do i=1,n
	ae(i)=0.0d0
	ic=0
	do j=1,nx*ny
		if (kk(j).ge.dfloat(i-1).and.kk(j).le.(dfloat(i)-tiny)) then
		ic=ic+1
		ae(i)=ae(i)+ee(j)
		end if
	end do
	ae(i)=ae(i)/dfloat(ic)
end do

! Define the file name
filename = "spectrum_averaged_"// trim(adjustl(snapID)) //'.plt'

open(unit=800, file=filename)
write(800,*)'variables ="k","E"'
do i=1,n
write(800,*)dfloat(i),ae(i)*(2.0d0*pi*(dfloat(i)))
end do
close(800)

! Define the file name
filename = "spectrum_averaged_new"// trim(adjustl(snapID)) //'.plt'

open(unit=805, file=filename)
write(805,*)'variables ="k","E"'
do i=1,n
write(805,*)dfloat(i),ae(i)
end do
close(805)

open(15,file="k3.plt")
write(15,*) 'variables ="k","E"'
write(15,*)2.0d0, 1.0d0
write(15,*)200.0d0, 1.0d-6
close(15)

deallocate(data1d,data2d,u1,u2,kk,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute spectrum from vorticity
!-----------------------------------------------------------------!
subroutine specw(nx,ny,w,ifile)
implicit none
integer ::nx,ny,n,ic,ifile
double precision::pi
integer::i,j,k,k1,k2
real*8 ::w(0:nx,0:ny)

real*8,parameter:: tiny=1.0d-10,tiny2=1.0d-14
real*8,dimension(:),allocatable:: data1d,wa2,kk,ee,ae

integer,parameter::ndim=2
integer::nn(ndim),isign
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

pi = 4.0d0*datan(1.0d0)

allocate(data1d(2*nx*ny),wa2(nx*ny),kk(nx*ny),ee(nx*ny))

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of w
!invese fourier transform
k=1
do j=1,ny
do i=1,nx
data1d(k)  =w(i,j)
data1d(k+1)=0.0d0
k=k+2
end do
end do

isign=-1
call fourn(data1d,nn,ndim,isign)

do j=1,2*nx*ny
data1d(j)=data1d(j)/dfloat(nx*ny)
end do

! absolute value of vorticity coefficients in fourier space
k=1
do j=1,nx*ny
wa2(j)=data1d(k)*data1d(k) + data1d(k+1)*data1d(k+1)
k=k+2
end do

! wave numbers
k=1
do k2 = 0,ny/2
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1= -nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

do k2 =-ny/2+1,-1
	do k1= 0,nx/2
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
	do k1=-nx/2+1,-1
	kk(k)  = dsqrt(dfloat(k1)*dfloat(k1) + dfloat(k2)*dfloat(k2))
	k=k+1
	end do
end do

! energy spectrum logaritmic scale
filename = "spectrum_vor_scattered_"// trim(adjustl(snapID)) //'.plt'

open(unit=701, file=filename)
write(701,*)'variables ="log(k)","log(e)"'

k=0
do j=1,nx*ny
if(dabs(kk(j)).ge.tiny) then
	ee(j)=wa2(j)*pi/kk(j)
	if (ee(j).le.tiny2) ee(j)=tiny2
	k=k+1
	kk(k) = dlog10(kk(j))
	ee(k) = dlog10(ee(j))
	write(701,103)kk(k),ee(k)
end if
end do
close(701)

! avaraged energy spectrum

n=int(sqrt(float(nx*ny))*sqrt(2.0)/2.0 )-1
allocate(ae(n))

!averaging!
do i=1,n
	ae(i)=0.0d0
	ic=0
	do j=1,nx*ny
		if (kk(j).ge.dlog10(dfloat(i)-0.5d0).and.kk(j).le.dlog10(dfloat(i)+0.5d0)) then
		ic=ic+1
		ae(i)=ae(i)+ee(j)
		end if
	end do
	ae(i)=ae(i)/dfloat(ic)
end do

filename = "spectrum_vor_averaged_"// trim(adjustl(snapID)) //'.plt'

open(unit=702, file=filename)
write(702,*)'variables ="log(k)","log(e)"'
do i=1,n
write(702,*)dlog10(dfloat(i)),ae(i)
end do

close(702)

deallocate(data1d,wa2,kk,ee,ae)

103 format(2e16.6)

return
end

!-----------------------------------------------------------------!
!Spectrum new
!-----------------------------------------------------------------!
subroutine specnew(nx,ny,w,ifile)
implicit none
integer ::nx,ny,ifile
double precision::w(0:nx,0:ny)
double precision::pi
integer::i,j,k,n,ic
double precision::kx(0:nx-1),ky(0:ny-1),kk
double precision,parameter:: tiny=1.0d-10
double precision,dimension(:),allocatable:: data1d,en
double precision,dimension(:,:),allocatable::es
integer,parameter::ndim=2
integer::nn(ndim),isign
character(80):: snapID,filename

write(snapID,'(i5)') ifile      !index for time snapshot

allocate(data1d(2*nx*ny))

pi = 4.0d0*datan(1.0d0)

nn(1)= nx
nn(2)= ny

!finding fourier coefficients of w
!invese fourier transform
!find the vorticity in Fourier space
k=1
do j=0,ny-1
do i=0,nx-1
	data1d(k)   =  w(i,j)
	data1d(k+1) =  0.0d0
k = k + 2
end do
end do
!normalize
do k=1,2*nx*ny
data1d(k)=data1d(k)/dfloat(nx*ny)
end do
!inverse fourier transform
isign= -1
call fourn(data1d,nn,ndim,isign)

!Wave numbers
do i=0,nx/2-1
kx(i)      = dfloat(i)
kx(i+nx/2) = dfloat(i-nx/2)
end do
kx(0) = tiny

do j=0,ny/2-1
ky(j)      = dfloat(j)
ky(j+ny/2) = dfloat(j-ny/2)
end do
ky(0) = tiny

!Energy spectrum (for all wavenumbers)
allocate(es(0:nx-1,0:ny-1))
k=1
do j=0,ny-1
do i=0,nx-1
kk = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
es(i,j) = pi*(data1d(k)*data1d(k) + data1d(k+1)*data1d(k+1))/kk
k = k + 2
end do
end do

! energy spectrum logaritmic scale
filename = "spec_new_vor_scattered_"// trim(adjustl(snapID)) //'.plt'
open(unit=901, file=filename)
write(901,*)'variables ="k","E"'
do j=1,ny-1
do i=1,nx-1
kk = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
write(901,103) kk,es(i,j)
end do
end do
close(901)

!Plot angle avaraged energy spectrum
n = nint(0.5d0*dsqrt(dfloat(nx*nx + ny*ny)))-1
allocate(en(n))

do k=1,n
en(k) = 0.0d0
ic = 0
do j=1,ny-1
do i=1,nx-1
kk = dsqrt(kx(i)*kx(i) + ky(j)*ky(j))
    if(kk.ge.(dfloat(k)-0.5d0).and.kk.le.(dfloat(k)+0.5d0)) then
    ic = ic + 1
    en(k) = en(k) + es(i,j)
    end if
end do
end do
en(k) = en(k) / dfloat(ic)
end do

! Define the file name
filename = "spec_new_vor_averaged_"// trim(adjustl(snapID)) //'.plt'

open(unit=902, file=filename)
write(902,*)'variables ="k","E"'
do k=1,n
write(902,103)dfloat(k),en(k)
end do
close(902)

deallocate(data1d,es,en)

103 format(2e16.6)

return
end

!-----------------------------------------------------------------!
! fft routine from numerical recipes
! ndim: dimension of the transform (i.e.; 2 for 2d problems)
! nn  : number of points in each direction
! data: one-dimensional array including real and imaginary part
!-----------------------------------------------------------------!
subroutine fourn(data,nn,ndim,isign)
implicit none
integer:: ndim,isign
integer:: nn(ndim)
real*8:: data(*)
real*8:: wr,wi,wpr,wpi,wtemp,theta,tempr,tempi
integer::ntot,n,nrem,nprev,idim,ip1,ip2,ip3,i1,i2,i3
integer::i2rev,i3rev,ibit,ifp1,ifp2,k1,k2

      ntot=1
      do 11 idim=1,ndim
        ntot=ntot*nn(idim)
11    continue
      nprev=1
      do 18 idim=1,ndim
        n=nn(idim)
        nrem=ntot/(n*nprev)
        ip1=2*nprev
        ip2=ip1*n
        ip3=ip2*nrem
        i2rev=1
        do 14 i2=1,ip2,ip1
          if(i2.lt.i2rev)then
            do 13 i1=i2,i2+ip1-2,2
              do 12 i3=i1,ip3,ip2
                i3rev=i2rev+i3-i2
                tempr=data(i3)
                tempi=data(i3+1)
                data(i3)=data(i3rev)
                data(i3+1)=data(i3rev+1)
                data(i3rev)=tempr
                data(i3rev+1)=tempi
12            continue
13          continue
          endif
          ibit=ip2/2
1         if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then
            i2rev=i2rev-ibit
            ibit=ibit/2
          go to 1
          endif
          i2rev=i2rev+ibit
14      continue
        ifp1=ip1
2       if(ifp1.lt.ip2)then
          ifp2=2*ifp1
          theta=isign*6.28318530717959d0/(ifp2/ip1)
          wpr=-2.d0*dsin(0.5d0*theta)**2
          wpi=dsin(theta)
          wr=1.d0
          wi=0.d0
          do 17 i3=1,ifp1,ip1
            do 16 i1=i3,i3+ip1-2,2
              do 15 i2=i1,ip3,ifp2
                k1=i2
                k2=k1+ifp1
                tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1)
                tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2)
                data(k2)=data(k1)-tempr
                data(k2+1)=data(k1+1)-tempi
                data(k1)=data(k1)+tempr
                data(k1+1)=data(k1+1)+tempi
15            continue
16          continue
            wtemp=wr
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
17        continue
          ifp1=ifp2
        go to 2
        endif
        nprev=n*nprev
18    continue

return
end

!------------------------------------------------------------------!
! c6dp:  6th-order compact scheme for first-degree derivative(up)
!        periodic boundary conditions (0=n), h=grid spacing
!        tested
!------------------------------------------------------------------!
subroutine c6dp(u,up,h,n)
implicit none
integer :: n,i
double precision   :: h,alpha,beta
double precision , dimension (0:n)  :: u,up
double precision , dimension (0:n-1):: a,b,c,r,x

do i=0,n-1
a(i) = 1.0d0/3.0d0
b(i) = 1.0d0
c(i) = 1.0d0/3.0d0
end do

do i=2,n-2
r(i) = 14.0d0/9.0d0*(u(i+1)-u(i-1))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(i+2)-u(i-2))/(4.0d0*h)
end do
r(1) = 14.0d0/9.0d0*(u(2)-u(0))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(3)-u(n-1))/(4.0d0*h)

r(n-1) = 14.0d0/9.0d0*(u(n)-u(n-2))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(1)-u(n-3))/(4.0d0*h)

r(0) = 14.0d0/9.0d0*(u(1)-u(n-1))/(2.0d0*h) &
     + 1.0d0/9.0d0*(u(2)-u(n-2))/(4.0d0*h)

alpha = 1.0d0/3.0d0
beta  = 1.0d0/3.0d0

call ctdms(a,b,c,alpha,beta,r,x,0,n-1)

do i=0,n-1
up(i)=x(i)
end do
up(n)=up(0)

return
end

!----------------------------------------------------!
! solution tridiagonal systems (regular tri-diagonal)
! a:subdiagonal, b: diagonal, c:superdiagonal
! r:rhs, u:results
! s: starting index
! e: ending index
!----------------------------------------------------!
subroutine tdms(a,b,c,r,u,s,e)
implicit none
integer::s,e
double precision ::a(s:e),b(s:e),c(s:e),r(s:e),u(s:e)
integer::j
double precision ::bet,gam(s:e)
bet=b(s)
u(s)=r(s)/bet
do j=s+1,e
gam(j)=c(j-1)/bet
bet=b(j)-a(j)*gam(j)
u(j)=(r(j)-a(j)*u(j-1))/bet
end do
do j=e-1,s,-1
u(j)=u(j)-gam(j+1)*u(j+1)
end do
return
end

!-------------------------------------------------------------------!
! solution of cyclic tridiagonal systems (periodic tridiagonal)
! n:matrix size (starting from 1)
! a:subdiagonal, b: diagonal, c:superdiagonal
! r:rhs, x:results
! alpha:sub entry (first value in e-th eq.)
! beta: super entry (last value in s-th eq.)
!-------------------------------------------------------------------!
subroutine ctdms(a,b,c,alpha,beta,r,x,s,e)
implicit none
integer:: s,e
double precision :: alpha,beta,a(s:e),b(s:e),c(s:e),r(s:e),x(s:e)
integer:: i
double precision :: fact,gamma,bb(s:e),u(s:e),z(s:e)
if((e-s).le.2) then
write(*,*) ' matrix too small in cyclic'
stop
end if
gamma=-b(s)
bb(s)=b(s)-gamma
bb(e)=b(e)-alpha*beta/gamma
do i=s+1,e-1
bb(i)=b(i)
end do
call tdms(a,bb,c,r,x,s,e)
u(s)=gamma
u(e)=alpha
do i=s+1,e-1
u(i)=0.0d0
end do
call tdms(a,bb,c,u,z,s,e)
fact=(x(s)+beta*x(e)/gamma)/(1.0d0+z(s)+beta*z(e)/gamma)
do i=s,e
x(i)=x(i)-fact*z(i)
end do
return
end

!-----------------------------------------------------------------!
!Probability density function writing
!very naive way
!-----------------------------------------------------------------!
subroutine pdfdist2d(nx,ny,rh,u,v,w,ifile)
implicit none
integer::nx,ny,ifile,l,ii
real*8 ::rh(0:nx,0:ny)
real*8 ::u(0:nx,0:ny)
real*8 ::v(0:nx,0:ny)
real*8 ::w(0:nx,0:ny)
real*8,allocatable ::du(:),uu(:),pu(:),nu(:)
character(80):: snapID,filename
integer::npdf,ndata,i,j

write(snapID,'(i5)') ifile      !index for time snapshot

npdf = 512  !number of bin in pdf computation

! writing pdf for vorticity
ndata = nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = w(i,j)
ii = ii + 1
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_vorticity_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "w", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

! writing pdf for vorticity difference
ndata = 2*nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = w(i,j)-w(i-1,j)
du(ii+1)=w(i,j)-w(i,j-1)
ii = ii + 2
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_vorticity_dif_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "dw", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

! writing pdf for density
ndata = nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = rh(i,j)
ii=ii+1
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_rho_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "rho", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

! writing pdf for density difference in x
ndata = 2*nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = rh(i,j)-rh(i-1,j)
du(ii+1) = rh(i,j)-rh(i,j-1)
ii=ii+2
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_rho_dif_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "dr", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

! writing pdf for velocity difference in longitudinal
ndata = 2*nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = u(i,j)-u(i-1,j)
du(ii+1) = v(i,j)-v(i,j-1)
ii=ii+2
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_vel_longitudinal_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "du_longitudinal", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

! writing pdf for velocity difference in transverse
ndata=2*nx*ny
allocate(du(ndata),uu(npdf),pu(npdf),nu(npdf))
ii=1
do j = 1,ny
do i = 1,nx
du(ii) = u(i,j)-u(i,j-1)
du(ii+1) = v(i,j)-v(i-1,j)
ii=ii+2
end do
end do

call pdf2d(ndata,npdf,du,uu,pu,nu)
! Define the file name
filename = "pdf_vel_transverse_"// trim(adjustl(snapID)) //'.plt'

open(unit=19, file=filename)
write(19,*) 'variables = "du_transverse", "PDF","G"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', npdf, ' f=point'
do l=1,npdf
write(19,*)uu(l),pu(l),nu(l)
end do
close(19)
deallocate(du,uu,pu,nu)

return
end

!-----------------------------------------------------------------!
!Probability density function computing
!-----------------------------------------------------------------!
subroutine pdf2d(ndata,npdf,du,uu,pu,nu)
implicit none
integer::ndata,npdf
real*8 ::du(ndata),uu(npdf),pu(npdf),nu(npdf),uf(0:npdf)
integer::ii,l
real*8 ::dmax,dmin,sum,mean,sd,pi

pi = 4.0d0*datan(1.0d0)

!dmax = maxval(du)
!dmin = minval(du)

!normalize the data (z-score):

!compute mean:
mean = 0.0d0
do ii=1,ndata
mean = mean + du(ii)
end do
mean = mean/dfloat(ndata)

!standard deviation:
sd = 0.0d0
do ii=1,ndata
sd = sd + (du(ii)-mean)**2
end do
sd = sd/dfloat(ndata)
sd = dsqrt(sd)

dmax = min(mean + sd*4.0d0, maxval(du))
dmin = max(mean - sd*4.0d0, minval(du))

do l = 1,npdf
  pu(l) = 0.0d0
end do

do l = 0,npdf
  !if (l.le.npdf/2) then
  !uf(l) = dmin + ((dmax-dmin)/2.0d0)*dsin(dfloat(l)/dfloat(npdf)*pi)
  !else
  !uf(l) = dmax - ((dmax-dmin)/2.0d0)*dsin(dfloat(l)/dfloat(npdf)*pi)
  !end if
  uf(l) = dmin + (dmax-dmin)*dfloat(l)/dfloat(npdf)
end do

do l = 1,npdf
do ii=1,ndata
if (du(ii).lt.uf(l).and.du(ii).ge.uf(l-1)) then
pu(l) = pu(l)+1.0d0
end if
end do
uu(l) = 0.5d0*(uf(l)+uf(l-1))
nu(l) = 1.0d0/dsqrt(2.0d0*pi*sd**2)*dexp(-((uu(l)-mean)**2)/(2.0d0*(sd**2)))
end do

sum = 0.0d0
do l = 1,npdf
  sum = sum + pu(l)*(uf(l)-uf(l-1))
end do

if (sum.le.1.0d0) sum = 1.0d0

!normalize to give sum=1.0d0
do l = 1,npdf
  pu(l) = pu(l)/sum
end do

return
end


submodule(forlab) forlab_issquare
    use forlab_kinds

contains
        logical module function issquare_rsp (A)
            !！ issquare0 determines whether a real matrix is square.
            real(sp), dimension(:, :), intent(in) :: A

            issquare_rsp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_rsp = .true.
            return
        end function
        logical module function issquare_rdp (A)
            !！ issquare0 determines whether a real matrix is square.
            real(dp), dimension(:, :), intent(in) :: A

            issquare_rdp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_rdp = .true.
            return
        end function
        logical module function issquare_rqp (A)
            !！ issquare0 determines whether a real matrix is square.
            real(qp), dimension(:, :), intent(in) :: A

            issquare_rqp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_rqp = .true.
            return
        end function
        logical module function issquare_csp (A)
            !！ issquare0 determines whether a real matrix is square.
            complex(sp), dimension(:, :), intent(in) :: A

            issquare_csp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_csp = .true.
            return
        end function
        logical module function issquare_cdp (A)
            !！ issquare0 determines whether a real matrix is square.
            complex(dp), dimension(:, :), intent(in) :: A

            issquare_cdp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_cdp = .true.
            return
        end function
        logical module function issquare_cqp (A)
            !！ issquare0 determines whether a real matrix is square.
            complex(qp), dimension(:, :), intent(in) :: A

            issquare_cqp = .false.
            if (size(A, 1) .eq. size(A, 2)) issquare_cqp = .true.
            return
        end function
end submodule


	subroutine indexx(n, arrin, indx)

	implicit none

c	Parameters:
	integer	n
	real	arrin(n)
	integer	indx(n)

c	Local variables:
	integer	i
	integer	indxt
	integer	ir
	integer	j
	integer	l
	real	q

      if (n.lt.1) then
         return
      else if (n.eq.1) then
         indx(1) = 1
         return
      endif

      DO 11 J=1,N
        INDX(J)=J
11    CONTINUE
      L=N/2+1
      IR=N
10    CONTINUE
        IF(L.GT.1)THEN
          L=L-1
          INDXT=INDX(L)
          Q=ARRIN(INDXT)
        ELSE
          INDXT=INDX(IR)
          Q=ARRIN(INDXT)
          INDX(IR)=INDX(1)
          IR=IR-1
          IF(IR.EQ.1)THEN
            INDX(1)=INDXT
            RETURN
          ENDIF
        ENDIF
        I=L
        J=L+L
20      IF(J.LE.IR)THEN
          IF(J.LT.IR)THEN
            IF(ARRIN(INDX(J)).LT.ARRIN(INDX(J+1)))J=J+1
          ENDIF
          IF(Q.LT.ARRIN(INDX(J)))THEN
            INDX(I)=INDX(J)
            I=J
            J=J+J
          ELSE
            J=IR+1
          ENDIF
        GO TO 20
        ENDIF
        INDX(I)=INDXT
      GO TO 10
      END


program main
    use double
    use plot
    implicit none
    !real(kind=rdp) :: x
    !x = 0
    !x = bessel_j0(x)
    !write(*,*) "x = ", x
    !write(*,*) "hello world"

    integer, parameter :: n = 10
    real(kind=rdp), dimension(10) :: x, y
    integer :: i

    do i = 1, n
        x(i) = 0.1 * i
        y(i) = x(i) * x(i)
    enddo

    call plot2d(x, y)
end program main


subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

   implicit real*8(a-h,o-z)
   dimension q(meqn, 1-mbc:mx+mbc)
   real(kind=8) :: mu1,mu2

   common /cparam/ mu1,mu2

   ! reactive source term

   do i=1,mx+mbc
      xcell = xlower + (i-0.5d0)*dx
      q(1,i) = q(1,i) - dt*mu1*(q(1,i)-1.0d0)*(q(1,i)-mu2)*q(1,i)
   end do
end subroutine src1


SUBROUTINE SMOOTHSPEC(lambda,spec,sigma,minl,maxl,ires)

  !routine to compute velocity broadening of an input spectrum
  !this is only approximate b/c we are ignoring the variation
  !in dlambda with lambda within each integration
  !integration is truncated at +/-4*sigma.
  !If optional input ires is present, then the spectrum will be
  !smoothed by a wavelength dependent velocity dispersion.

  USE sps_vars; USE sps_utils, ONLY : locate,linterp,tsum,linterparr
  IMPLICIT NONE

  REAL(SP), INTENT(inout), DIMENSION(nspec) :: spec
  REAL(SP), INTENT(in), DIMENSION(nspec)    :: lambda
  REAL(SP), INTENT(in), DIMENSION(nspec), OPTIONAL :: ires
  REAL(SP), INTENT(in) :: sigma,minl,maxl
  REAL(SP), DIMENSION(nspec) :: tspec,tnspec,vel,func,gauss,psf,lnlam
  REAL(SP) :: ckms,cg,xmax,xmin,fwhm,psig,dlstep,sigmal
  INTEGER :: i,j,il,ih,m=4,grange

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  IF (sigma.LE.tiny_number) RETURN

  ckms = clight/1E13

  tspec = spec

  !convolve at fixed sigma_velocity
  IF (smooth_velocity.EQ.1) THEN

     !compute smoothing the fast (and slightly less accurate) way
     IF (smoothspec_fast.EQ.1.OR.PRESENT(ires)) THEN

        spec = 0.0

        DO i=1,nspec

           IF (lambda(i).LT.minl.OR.lambda(i).GT.maxl) THEN
              spec(i)=tspec(i)
              CYCLE
           ENDIF

           IF (PRESENT(ires)) THEN
              sigmal = ires(i)
              IF (sigmal.LE.tiny_number) THEN
                 spec(i)=tspec(i)
                 CYCLE
              ENDIF
           ELSE
              sigmal = sigma
           ENDIF

           xmax = lambda(i)*(m*sigmal/ckms+1)
           ih   = MIN(locate(lambda(1:nspec),xmax),nspec)
           il   = MAX(2*i-ih,1)

           IF (il.EQ.ih) THEN
              spec(i) = tspec(i)
           ELSE
              vel(il:ih)  = (lambda(i)/lambda(il:ih)-1)*ckms
              func(il:ih) =  1/SQRT(2*mypi)/sigmal * &
                   EXP(-vel(il:ih)**2/2./sigmal**2)
              !normalize the weights to integrate to unity
              func(il:ih) = func(il:ih) / TSUM(vel(il:ih),func(il:ih))
              spec(i) = TSUM(vel(il:ih),func(il:ih)*tspec(il:ih))
          ENDIF

        ENDDO

     !compute smoothing the correct (and somewhat slower) way
     !NB: the accuracy of this approach depends strongly on the
     !min/max wavelength parameters through the density of the lnlam grid
     ELSE

        dlstep = (LOG(maxl)-LOG(minl))/nspec
        DO i=1,nspec
           lnlam(i) = i*dlstep+LOG(minl)
        ENDDO

        tspec = linterparr(LOG(lambda(1:nspec)),spec(1:nspec),lnlam)

        fwhm   = sigma*2.35482/ckms/dlstep
        psig   = fwhm/2.0/SQRT(-2.0*LOG(0.5)) ! equivalent sigma for kernel
        grange = FLOOR(m*psig)	              ! range for kernel (-range:range)

        DO i=1,2*grange+1
           psf(i) = 1.d0/SQRT(2.*mypi)/psig*EXP(-((i-grange-1)/psig)**2/2.)
        ENDDO
        psf(1:2*grange+1) = psf(1:2*grange+1) / SUM(psf(1:2*grange+1))

        DO i=grange+1,nspec-grange
           tnspec(i) = SUM( psf(1:2*grange+1)*tspec(i-grange:i+grange) )
        ENDDO

        !the ends are not smoothed
        DO i=1,grange
           tnspec(i)=tspec(i)
        ENDDO
        DO i=nspec-grange+1,nspec
           tnspec(i)=tspec(i)
        ENDDO

        !interpolate back to the main array
        il = locate(lambda,minl)
        ih = locate(lambda,maxl)
        spec(il:ih) = linterparr(EXP(lnlam),tnspec,lambda(il:ih))

     ENDIF

  !convolve at fixed sigma_wavelength
  ELSE

     DO i=1,nspec

        IF (lambda(i).LT.minl.OR.lambda(i).GT.maxl) THEN
           spec(i)=tspec(i)
           CYCLE
        ENDIF

        xmax = lambda(i)*(m*sigma+1)
        ih   = MIN(locate(lambda(1:nspec),xmax),nspec)
        il   = MAX(2*i-ih,1)

        IF (il.EQ.ih) THEN
           spec(i) = tspec(i)
        ELSE
           func(il:ih) =  1/SQRT(2*mypi)/sigma * &
                EXP(-(lambda(il:ih)-lambda(i))**2/2./sigma**2)
           !normalize the weights to integrate to unity
           func(il:ih) = func(il:ih) / TSUM(lambda(il:ih),func(il:ih))
           spec(i) = TSUM(lambda(il:ih),func(il:ih)*tspec(il:ih))
        ENDIF

        !gauss = 1/SQRT(2*mypi)/sigma*EXP(-(lambda-lambda(i))**2/2/sigma**2)
        !DO j=1,nspec
        !   spec(i) = spec(i) + gauss(j)*tspec(j)
        !ENDDO

    ENDDO

  ENDIF

  RETURN

END SUBROUTINE SMOOTHSPEC


DOUBLE PRECISION function poisson_qexact(x,y)
    IMPLICIT NONE

    DOUBLE PRECISION x,y

    INTEGER example
    COMMON /comm_example/ example

    INTEGER flag
    DOUBLE PRECISION grad(2), q, qlap

    flag = 0  !! Don't compute the gradient
    call poisson_qexact_complete(example,x,y,q,qlap,grad,flag)

    poisson_qexact = q

end function poisson_qexact

DOUBLE PRECISION function poisson_qexact_rhs(x,y)
    implicit none

    double precision x,y

    INTEGER example
    COMMON /comm_example/ example

    integer flag
    double precision q,qlap,b, grad_q(2), grad_beta(2)

    CALL poisson_fort_beta(x,y,b,grad_beta)

    flag = 2
    CALL poisson_qexact_complete(example,x,y,q,qlap,grad_q,flag)

    poisson_qexact_rhs = grad_beta(1)*grad_q(1) +  grad_beta(2)*grad_q(2) + b*qlap

END FUNCTION poisson_qexact_rhs

SUBROUTINE poisson_qexact_gradient(x,y,q,grad)
    IMPLICIT NONE

    DOUBLE PRECISION x,y, q, grad(2)

    INTEGER flag
    DOUBLE PRECISION qlap

    INTEGER example
    COMMON /comm_example/ example

    flag = 1
    CALL poisson_qexact_complete(example,x,y,q,qlap,grad,flag)

END SUBROUTINE poisson_qexact_gradient

SUBROUTINE poisson_qexact_complete(example,x,y,q,qlap,grad,flag)
    use hsmooth_mod, only : m_polar, x0_polar, y0_polar
    IMPLICIT NONE

    DOUBLE PRECISION x,y, q, qlap, grad(2)
    INTEGER flag, example

!!    INTEGER example
!!    COMMON /comm_example/ example

    DOUBLE PRECISION alpha,x0,y0,a,b
    COMMON /comm_rhs/ alpha,x0,y0,a,b

    DOUBLE PRECISION pi,pi2
    COMMON /compi/ pi, pi2

    DOUBLE PRECISION r, r2, theta
    double precision hsmooth, h_grad(2), hsmooth_laplacian
    DOUBLE PRECISION qx,qy, dqdr, t1(2), t2(2)
    double precision q1, qx1, qy1, qlap1, x0p,y0p
    integer id

    if (example .eq. 0) then
        q = x**2 + y**2
        qx = 2*x
        qy = 2*y
        qlap = 4
    elseif (example .eq. 1) then
        !! example in polar coordinates (r)
        r2 = (x-x0)**2 + (y-y0)**2
        q1 = exp(-alpha/2.d0*r2)
        q = q1 + 1
        if (flag .ge. 1) then
            r = sqrt(r2)
            t1(1) = (x-x0)/r
            t1(2) = (y-y0)/r
            dqdr = -alpha*r*q1
            qx = dqdr*t1(1)  !! Cartesian components of gradient
            qy = dqdr*t1(2)
            if (flag .eq. 2) then
                qlap = alpha*exp(-alpha/2.d0*r2)*(alpha*r2 - 2)
            endif
        endif
    elseif (example .eq. 2) then
        !! Example in Cartesian coordinates
        q = cos(pi*a*x)*cos(pi*b*y)
        if (flag .ge. 1) then
            qx =  pi*a*cos(pi*a*x)*cos(pi*b*y)
            qy = -pi*b*sin(pi*a*x)*sin(pi*b*y)
            if (flag .eq. 2 ) then
                qlap = -(pi**2*(a**2 + b**2))*cos(pi*a*x)*cos(pi*b*y)
            endif
        endif
    elseif (example .eq. 3) then
        !! d/(dx)((1 - x) x (1 - y) y exp(x y)) = (y - 1) y e^(x y) (x^2 y - (y - 2) x - 1)
        !! d/(dy)((1 - x) x (1 - y) y exp(x y)) = (x - 1) x e^(x y) (x y^2 - (x - 2) y - 1)
        q = (1-x)*x*(1-y)*y*exp(x*y)

        if (flag .ge. 1) then
            qx = (y - 1)*y*exp(x*y)*(x**2*y - (y - 2)*x - 1)
            qy = (x - 1)*x*exp(x*y)*(x*y**2 - (x - 2)*y - 1)
            if (flag .eq. 2) then
                !!Δ((1 - x) x (1 - y) y e^(x y)) =
                !! e^(x y) (x^4 (y - 1) y
                !! - x^3 (y^2 - 5 y + 2)
                !! + x^2 (y^4 - y^3 - 4 y + 4)
                !! - x (y^4 - 5 y^3 + 4 y^2 + 2)
                !! - 2 (y - 1)^2 y)
                qlap = exp(x*y)*(x**4*(y - 1)*y &
                                 - x**3*(y**2 - 5*y + 2) &
                                 + x**2*(y**4 - y**3 - 4*y + 4) &
                                 - x*(y**4 - 5*y**3 + 4*y**2 + 2) &
                                 - 2*(y - 1)**2*y)
            endif
        endif
    elseif (example .eq. 4) then
        q = 0
        qx = 0
        qy = 0
        qlap = 0
        do id = 1,m_polar
            x0p = x0_polar(id)
            y0p = y0_polar(id)
            r = sqrt((x-x0p)**2 + (y-y0p)**2)
            theta = atan2(y-y0p,x-x0p)
            q1 = 1 - hsmooth(id,r,theta)
            if (flag .ge. 1) then
                !! Assume mapping is T(r,theta)
                t1(1) = cos(theta)
                t1(2) = sin(theta)
                t2(1) = -r*sin(theta)
                t2(2) = r*cos(theta)

                !! Cartesian components of the gradient
                call hsmooth_grad(id,r,theta,h_grad)
                qx1 = -(h_grad(1)*t1(1) + h_grad(2)*t2(1))
                qy1 = -(h_grad(1)*t1(2) + h_grad(2)*t2(2))

                !! Laplacian
                if (flag .eq. 2) then
                    qlap1 = -hsmooth_laplacian(id,r,theta)
                endif
            endif
            q = q + q1
            qx = qx + qx1
            qy = qy + qy1
            qlap = qlap + qlap1
        enddo
    endif
    if (flag .ge. 1) then
        grad(1) = qx
        grad(2) = qy
    endif

end subroutine poisson_qexact_complete

double precision function sech(x)
    implicit none

    double precision x

    sech = 1.d0/cosh(x)
end function sech

subroutine poisson_fort_beta(x,y,b,grad)
    implicit none

    double precision x,y,b,grad(2)

    integer beta_choice
    common /comm_beta/ beta_choice

    DOUBLE PRECISION pi,pi2
    COMMON /compi/ pi, pi2

    DOUBLE PRECISION bx, by

    if (beta_choice .eq. 0) then
        b = 1
        bx = 0
        by = 0
    elseif (beta_choice .eq. 1) then
        b = cos(pi*x)*cos(pi*y) + 2
        bx = -pi*sin(pi*x)*cos(pi*y)
        by = -pi*cos(pi*x)*sin(pi*y)
    elseif (beta_choice .eq. 2) then
        b = 1 + x*y
        bx = y
        by = x
    endif

    grad(1) = bx
    grad(2) = by

end subroutine poisson_fort_beta


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine richnk (nn,y,bh,dh)
c     ================================================================
c
c     ****************************************************************
c     calculates the riccati-bessel functions hl.
c     this version calculates the derivatives.
c     ****************************************************************
c
      implicit   none
c
      integer    l
      integer    nn
c
      complex*16 bh(nn)
      complex*16 dh(nn)
      complex*16 y
c
      complex*16 x
      complex*16 xinv
      complex*16 xpon
      complex*16 one
      complex*16 sqrtm1
      complex*16 zero
c
      parameter (zero=(0.d0,0.d0))
      parameter (one=(1.d0,0.d0))
      parameter (sqrtm1=(0.d0,1.d0))
c
      x=y
      if (abs(x).eq.0.d00) then
         write(6,'('' trouble in richnk argument ='',2f10.5)') x
	 call fstop('richnk')
      endif
c
c     ================================================================
c     recursion relations
c     ================================================================
      xpon=exp( sqrtm1*x )
      xinv=one/x
      bh(1)=-sqrtm1
      bh(2)= - one - sqrtm1*xinv
      dh(1)= one
      dh(2)= sqrtm1 * ( xinv - ( sqrtm1 + x ) ) * xinv
c
c     ================================================================
c     flm=2l+1 for real l=0,1,2,3, ...  quantum number
c     ================================================================
      do l=3,nn
         bh(l) = (2*l-3)*bh(l-1)*xinv - bh(l-2)
         dh(l) = bh(l-1) - (l-1)*bh(l)*xinv
      enddo
      do l=1,nn
         bh(l)=bh(l)*xpon
         dh(l)=dh(l)*xpon
      enddo
c
      if( abs(x) .le. 0.01d0 ) then
c        =============================================================
c        power-series for j if abs(x) is smaller than 0.9. trouble!!!
c        =============================================================
! commented out in MST2
!     write(6,'('' trouble in richnk: small argument'')')
!         call fstop('richnk')
      endif
c
      return
      end


      SUBROUTINE MFFTRD(C,ISV,ISE,NV,NE,RW)
*
*   PURPOSE:
*       THIS ROUTINE PERFORMS THE POST-PROCESSING PHASE FOR
*       REAL 2-DIMENSIONAL DFT'S, ACCORDING TO FORMULA (2.7)
*       IN REF.[1].
*       POST-PROCESSING ACTS AFTER COMPUTING THE COMPLEX DFT
*       AND EVENTUAL REORDERING (CALLS TO MFFTDV AND MFFTOV).
*       IT APPLIES TO A VECTOR-OF-VECTORS-OF-COMPLEX
*               C[IVS,NV [IES,NE]].
*       SEE REF.[1] FOR NOTATIONS.
*
*   ARGUMENTS:
*      INPUT:
*       C : DATA ARRAY, OUTPUT FROM MFFTDV, MFFTOV; TO BE DECLARED
*                      REAL C(ISE*2,NE)
*           IN THE CALLING PROGRAM.
*     ISV : SEPARATION OF ELEMENTS IN A COLUMN OF C (USUALLY 1)
*     ISE : SEPARATION OF ELEMENTS IN A ROW OF C, DIVIDED BY 2
*      NV : NO. OF ELEMENTS TO BE PROCESSED IN A COLUMN OF C
*      NE : NO. OF ELEMENTS IN A ROW OF C, DIVIDED BY 2.
*      RW : COMPLEX ARRAY OF LENGHT AT LEAST NV; IT MUST
*           BE INITIALIZED BY A CALL TO MFFTRP; IT REMAINS
*           UNCHANGED IN OUTPUT.
*
*  OUTPUT : POST-PROCESSED ARRAY C
*
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C(0:ISV-1,0:*),T1,T2
      COMPLEX RW(0:*)
*
      IF (NV.GT.1) THEN
      DO 200 IV=1,(NV-1)/2
       DO 190 IE=0,(NE-1)*ISE,ISE
*
      T1=C(IE,IV)
      T2=C(IE,NV-IV)
      C(IE,IV)=((T1+CONJG(T2))+(RW(IV)*(T1-CONJG(T2))))*0.5
      C(IE,NV-IV)=(CONJG(T1+CONJG(T2))-CONJG(RW(IV)*(T1-CONJG(T2))))*0.5
*
 190   CONTINUE
 200  CONTINUE
*
*
      IF(2*IV.EQ.NV) THEN
        DO 210 IE=0,(NE-1)*ISE,ISE
        C(IE,IV)=CONJG(C(IE,IV))
 210  CONTINUE
*
      ENDIF
*
       ENDIF

      DO 300 IE=0,(NE-1)*ISE,ISE
        T1=C(IE,0)
        C(IE,0)=(DREAL(T1)+DIMAG(T1))
        C(IE,NV)=(DREAL(T1)-DIMAG(T1))
 300  CONTINUE
*
*
      END


*DECK R9LGIC
      FUNCTION R9LGIC (A, X, ALX)
C***BEGIN PROLOGUE  R9LGIC
C***SUBSIDIARY
C***PURPOSE  Compute the log complementary incomplete Gamma function
C            for large X and for A .LE. X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGIC-S, D9LGIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X,
C             LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log complementary incomplete gamma function for large X
C and for A .LE. X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGIC
      SAVE EPS
      DATA EPS / 0.0 /
C***FIRST EXECUTABLE STATEMENT  R9LGIC
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
C
      XPA = X + 1.0 - A
      XMA = X - 1.0 - A
C
      R = 0.0
      P = 1.0
      S = P
      DO 10 K=1,200
        FK = K
        T = FK*(A-FK)*(1.0+R)
        R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 20
 10   CONTINUE
      CALL XERMSG ('SLATEC', 'R9LGIC',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2)
C
 20   R9LGIC = A*ALX - X + LOG(S/XPA)
C
      RETURN
      END


      subroutine SROTMG (D1,D2,X1,Y1,PARAM)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2006-06-07 SROTMG Krogh  Removed arithmetic ifs
C>> 1999-12-30 SROTMG Krogh  Big reorg., no more assigned goto's.
C>> 1999-12-22 SROTMG Krogh  Declared IGO.
C>> 1994-10-20 SROTMG Krogh  Changes to use M77CON
C>> 1994-04-19 SROTMG Krogh   Converted to use generic intrinsics.
C>> 1985-08-02 SROTMG Lawson  Initial code.
c--S replaces "?": ?ROTMG
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(D1)*X1,SQRT(D2)*
C     Y1)**T.
C     WITH PARAM(1)=PFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     PFLAG=-1.E0     PFLAG=0.E0        PFLAG=1.E0     PFLAG=-2.E0
C
C       (H11  H12)    (1.E0  H12)    (H11  1.E0)    (1.E0  0.E0)
C     H=(        )    (         )    (         )    (          )
C       (H21  H22),   (H21  1.E0),   (-1.E0 H22),   (0.E0  1.E0).
C     LOCATIONS 2-5 OF PARAM CONTAIN H11, H21, H12, AND H22
C     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
C     VALUE OF PARAM(1) ARE NOT STORED IN PARAM.)
C
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF D1 AND D2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      real             GAM, RGAMSQ, D2, H11, H21, PARAM(5), P2,
     1     Q2, U, Y1, GAMSQ, D1, PFLAG, H12, H22, P1, Q1,
     2     TEMP, X1
C
      data GAM, GAMSQ, RGAMSQ / 4096.E0, 16777216.E0, 5.9604645E-8 /

      if ( D1 .lt. 0.E0) go to 210
      P2 = D2 * Y1
      if (P2 .eq. 0.E0) then
         PFLAG = -2.E0
         go to 260
      end if
C     Regular case
      P1 = D1 * X1
      Q2 = P2 * Y1
      Q1 = P1 * X1
      if (ABS(Q1) .gt. ABS(Q2)) then
         H21 = -Y1 / X1
         H12 = P2 / P1
         U = 1.E0 - H12 * H21
         if (U .le. 0.E0) go to 210
         PFLAG = 0.E0
         D1 = D1 / U
         D2 = D2 / U
         X1 = X1 * U
      else
         if (Q2 .lt. 0.E0) go to 210
         PFLAG = 1.E0
         H11 = P1 / P2
         H22 = X1 / Y1
         U = 1.E0 + H11 * H22
         TEMP = D2 / U
         D2 = D1 / U
         D1 = TEMP
         X1 = Y1 * U
      end if

C     Scale Check
 100  if (D1 .le. D2) then
         if (D1 .le. RGAMSQ) then
            if (D1 .ne. 0.E0) then
               if (PFLAG .ge. 0.E0) go to 150
               D1 = D1 * GAM**2
               X1 = X1 / GAM
               H11 = H11 / GAM
               H12 = H12 / GAM
               go to 100
            end if
         end if
         if (ABS(D2) .lt. GAMSQ) go to 220
         if (PFLAG .ge. 0.E0) go to 150
         D2 = D2 / GAM**2
         H21 = H21 * GAM
         H22 = H22 * GAM
         go to 100
      else
         if (ABS(D2) .le. RGAMSQ) then
            if (PFLAG .ge. 0.E0) go to 150
            D2 = D2 * GAM**2
            H21 = H21 / GAM
            H22 = H22 / GAM
            go to 100
         end if
         if (D1 .lt. GAMSQ) go to 220
         if (PFLAG .ge. 0.E0) go to 150
         D1 = D1 / GAM**2
         X1 = X1 * GAM
         H11 = H11 * GAM
         H12 = H12 * GAM
         go to 100
      end if

C     Fix H
 150  if (PFLAG .eq. 0.E0) then
         H11 = 1.E0
         H22 = 1.E0
      else
         H21 = -1.E0
         H12 = 1.E0
      end if
      PFLAG = -1.E0
      go to 100

C     Zero H, D, and X1
 210  PFLAG = -1.E0
      H11 = 0.E0
      H12 = 0.E0
      H21 = 0.E0
      H22 = 0.E0
C
      D1 = 0.E0
      D2 = 0.E0
      X1 = 0.E0

C     Return
 220  continue
      if (PFLAG .eq. 0.E0) then
        PARAM(3) = H21
        PARAM(4) = H12
      else if (PFLAG .gt. 0.E0) then

        PARAM(2) = H11
        PARAM(5) = H22
      else
        PARAM(2) = H11
        PARAM(3) = H21
        PARAM(4) = H12
        PARAM(5) = H22
      end if
 260  PARAM(1) = PFLAG
      return
      end


program stats_test
    use :: stats_mod, only : stats_t, add_stats_value
    implicit none
    real :: value
    type(stats_t) :: stats = stats_t(0.0, 0.0, 0)
    integer :: i

    do i = 1, 10
        call random_number(value)
        call add_stats_value(stats, value)
    end do
    print *, 'mean', stats%sum/stats%n

end program stats_test


    ! This code has been adapted for vectorization.
! For more details on how to use it, see the Makefile of the chile2010 example.

!-----------------------------------------------------------------------
      subroutine riemann_aug_JCP(maxiter,meqn,mwaves,hL,hR,huL,huR, &
        hvL,hvR,bL,bR,uL,uR,vL,vR,phiL,phiR,pL,pR,sE1,sE2,drytol,g,rho, &
        sw1,sw2,sw3,fw11,fw12,fw13,fw21,fw22,fw23,fw31,fw32,fw33)
      !dir$ attributes forceinline :: riemann_aug_JCP
      !dir$ attributes vector: uniform(maxiter,meqn,mwaves,drytol,g,rho) :: riemann_aug_JCP

      ! solve shallow water equations given single left and right states
      ! This solver is described in J. Comput. Phys. (6): 3089-3113, March 2008
      ! Augmented Riemann Solvers for the Shallow Equations with Steady States and Inundation

      ! To use the original solver call with maxiter=1.

      ! This solver allows iteration when maxiter > 1. The iteration seems to help with
      ! instabilities that arise (with any solver) as flow becomes transcritical over variable topo
      ! due to loss of hyperbolicity.

      implicit none

      !input
      integer meqn,mwaves,maxiter

      !  Due to what seems to be a bug with the Intel Compilers (versions 16, 17 and 18 at least),
      !  these arrays declared as PRIVATE in a !$OMP SIMD loop (in rpn2_geoclaw_vec.f90) had
      !  to be decomposed into scalars.
      !  This may not be necessary for future versions of the Intel Compilers.

      !real(kind=8) fw(meqn,mwaves)
      !real(kind=8) sw(mwaves)
      real(kind=8) sw1,sw2,sw3,fw11,fw12,fw13,fw21,fw22,fw23,fw31,fw32,fw33
      real(kind=8) hL,hR,huL,huR,bL,bR,uL,uR,phiL,phiR,sE1,sE2
      real(kind=8) hvL,hvR,vL,vR,pL,pR
      real(kind=8) drytol,g,rho

      !local
      integer m,mw,k,iter
      real(kind=8) A(3,3)
      real(kind=8) r(3,3)
      real(kind=8) lambda(3)
      real(kind=8) del(3)
      real(kind=8) beta(3)

      real(kind=8) delh,delhu,delphi,delb,delnorm
      real(kind=8) rare1st,rare2st,sdelta,raremin,raremax
      real(kind=8) criticaltol,convergencetol,raretol
      real(kind=8) criticaltol_2, hustar_interface
      real(kind=8) s1s2bar,s1s2tilde,hbar,hLstar,hRstar,hustar
      real(kind=8) huRstar,huLstar,uRstar,uLstar,hstarHLL
      real(kind=8) deldelh,deldelphi,delP
      real(kind=8) s1m,s2m,hm
      real(kind=8) det1,det2,det3,determinant

      logical rare1,rare2,rarecorrector,rarecorrectortest,sonic

      ! used to pre-compute square roots
      real(kind=8) sqrt_ghL, sqrt_ghR, sqrt_ghm

      !determine del vectors
      delh = hR-hL
      delhu = huR-huL
      delphi = phiR-phiL
      delb = bR-bL
      delP = pR - pL
      delnorm = delh**2 + delphi**2

      !DIR$ FORCEINLINE
      call riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2, &
                                               1,drytol,g)

      ! pre-compute square roots:
      sqrt_ghL = sqrt(g*hL)
      sqrt_ghR = sqrt(g*hR)
      sqrt_ghm = sqrt(g*hm)

      lambda(1)= min(sE1,s2m) !Modified Einfeldt speed
      lambda(3)= max(sE2,s1m) !Modified Eindfeldt speed
      sE1=lambda(1)
      sE2=lambda(3)
      lambda(2) = 0.d0  ! ### Fix to avoid uninitialized value in loop on mw -- Correct?? ###

      hstarHLL = max((huL-huR+sE2*hR-sE1*hL)/(sE2-sE1),0.d0) ! middle state in an HLL solve

      !determine the middle entropy corrector wave------------------------
      rarecorrectortest=.false.
      rarecorrector=.false.
      if (rarecorrectortest) then
         sdelta=lambda(3)-lambda(1)
         raremin = 0.5d0
         raremax = 0.9d0
         if (rare1.and.sE1*s1m.lt.0.d0) raremin=0.2d0
         if (rare2.and.sE2*s2m.lt.0.d0) raremin=0.2d0
         if (rare1.or.rare2) then
            !see which rarefaction is larger
            rare1st=3.d0*(sqrt_ghL-sqrt_ghm)
            rare2st=3.d0*(sqrt_ghR-sqrt_ghm)
            if (max(rare1st,rare2st).gt.raremin*sdelta.and. &
              max(rare1st,rare2st).lt.raremax*sdelta) then
                  rarecorrector=.true.
               if (rare1st.gt.rare2st) then
                  lambda(2)=s1m
               elseif (rare2st.gt.rare1st) then
                  lambda(2)=s2m
               else
                  lambda(2)=0.5d0*(s1m+s2m)
               endif
            endif
         endif
         if (hstarHLL.lt.min(hL,hR)/5.d0) rarecorrector=.false.
      endif

!     ## Is this correct 2-wave when rarecorrector == .true. ??
      do mw=1,mwaves
         r(1,mw)=1.d0
         r(2,mw)=lambda(mw)
         r(3,mw)=(lambda(mw))**2
      enddo
      if (.not.rarecorrector) then
         lambda(2) = 0.5d0*(lambda(1)+lambda(3))
         !lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
         r(1,2)=0.d0
         r(2,2)=0.d0
         r(3,2)=1.d0
      endif
      !---------------------------------------------------

      !determine the steady state wave -------------------
      !criticaltol = 1.d-6
      ! MODIFIED:
      criticaltol = max(drytol*g, 1d-6)
      criticaltol_2 = sqrt(criticaltol)
      deldelh = -delb
      deldelphi = -0.5d0 * (hR + hL) * (g * delb + delp / rho)

      !determine a few quanitites needed for steady state wave if iterated
      hLstar=hL
      hRstar=hR
      uLstar=uL
      uRstar=uR
      huLstar=uLstar*hLstar
      huRstar=uRstar*hRstar

      !iterate to better determine the steady state wave
      convergencetol=1.d-6
!      do iter=1,maxiter  ! since maxiter=1, no loop needed!
         !determine steady state wave (this will be subtracted from the delta vectors)
         if (min(hLstar,hRstar).lt.drytol.and.rarecorrector) then
            rarecorrector=.false.
            hLstar=hL
            hRstar=hR
            uLstar=uL
            uRstar=uR
            huLstar=uLstar*hLstar
            huRstar=uRstar*hRstar
            lambda(2) = 0.5d0*(lambda(1)+lambda(3))
            !lambda(2) = max(min(0.5d0*(s1m+s2m),sE2),sE1)
            r(1,2)=0.d0
            r(2,2)=0.d0
            r(3,2)=1.d0
         endif

         hbar =  max(0.5d0*(hLstar+hRstar),0.d0)
         s1s2bar = 0.25d0*(uLstar+uRstar)**2 - g*hbar
         s1s2tilde= max(0.d0,uLstar*uRstar) - g*hbar

         !find if sonic problem
         ! MODIFIED from 5.3.1 version
         sonic = .false.
         if (abs(s1s2bar) <= criticaltol) then
            sonic = .true.
         else if (s1s2bar*s1s2tilde <= criticaltol**2) then
            sonic = .true.
         else if (s1s2bar*sE1*sE2 <= criticaltol**2) then
            sonic = .true.
         else if (min(abs(sE1),abs(sE2)) < criticaltol_2) then
            sonic = .true.
         else if (sE1 <  criticaltol_2 .and. s1m > -criticaltol_2) then
            sonic = .true.
         else if (sE2 > -criticaltol_2 .and. s2m <  criticaltol_2) then
            sonic = .true.
         else if ((uL+sqrt_ghL)*(uR+sqrt_ghR) < 0.d0) then
            sonic = .true.
         else if ((uL- sqrt_ghL)*(uR- sqrt_ghR) < 0.d0) then
            sonic = .true.
         end if

         !find jump in h, deldelh
         if (sonic) then
            deldelh =  -delb
         else
            deldelh = delb*g*hbar/s1s2bar
         endif
         !find bounds in case of critical state resonance, or negative states
         if (sE1.lt.-criticaltol.and.sE2.gt.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE2)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE1)
         elseif (sE1.ge.criticaltol) then
            deldelh = min(deldelh,hstarHLL*(sE2-sE1)/sE1)
            deldelh = max(deldelh,-hL)
         elseif (sE2.le.-criticaltol) then
            deldelh = min(deldelh,hR)
            deldelh = max(deldelh,hstarHLL*(sE2-sE1)/sE2)
         endif

         !find jump in phi, deldelphi
         if (sonic) then
            deldelphi = -g*hbar*delb
         else
            deldelphi = -delb*g*hbar*s1s2tilde/s1s2bar
         endif
         !find bounds in case of critical state resonance, or negative states
         deldelphi=min(deldelphi,g*max(-hLstar*delb,-hRstar*delb))
         deldelphi=max(deldelphi,g*min(-hLstar*delb,-hRstar*delb))
         deldelphi = deldelphi - hbar * delp / rho

         del(1)=delh-deldelh
         del(2)=delhu
         del(3)=delphi-deldelphi

         !Determine determinant of eigenvector matrix========
         det1=r(1,1)*(r(2,2)*r(3,3)-r(2,3)*r(3,2))
         det2=r(1,2)*(r(2,1)*r(3,3)-r(2,3)*r(3,1))
         det3=r(1,3)*(r(2,1)*r(3,2)-r(2,2)*r(3,1))
         determinant=det1-det2+det3

         !solve for beta(k) using Cramers Rule=================
         do k=1,3
            do mw=1,3
                  A(1,mw)=r(1,mw)
                  A(2,mw)=r(2,mw)
                  A(3,mw)=r(3,mw)
            enddo
            A(1,k)=del(1)
            A(2,k)=del(2)
            A(3,k)=del(3)
            det1=A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
            det2=A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
            det3=A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
            beta(k)=(det1-det2+det3)/determinant
         enddo

         !exit if things aren't changing -> removed to allow vectorization!
         !if (abs(del(1)**2+del(3)**2-delnorm).lt.convergencetol) exit
         delnorm = del(1)**2+del(3)**2
         !find new states qLstar and qRstar on either side of interface
         hLstar=hL
         hRstar=hR
         uLstar=uL
         uRstar=uR
         huLstar=uLstar*hLstar
         huRstar=uRstar*hRstar
         do mw=1,mwaves
            if (lambda(mw).lt.0.d0) then
               hLstar= hLstar + beta(mw)*r(1,mw)
               huLstar= huLstar + beta(mw)*r(2,mw)
            endif
         enddo
         do mw=mwaves,1,-1
            if (lambda(mw).gt.0.d0) then
               hRstar= hRstar - beta(mw)*r(1,mw)
               huRstar= huRstar - beta(mw)*r(2,mw)
            endif
         enddo

         if (hLstar.gt.drytol) then
            uLstar=huLstar/hLstar
         else
            hLstar=max(hLstar,0.d0)
            uLstar=0.d0
         endif
         if (hRstar.gt.drytol) then
            uRstar=huRstar/hRstar
         else
            hRstar=max(hRstar,0.d0)
            uRstar=0.d0
         endif

  !    enddo ! end iteration on Riemann problem  ! since maxiter=1, no loop needed!

!       do mw=1,mwaves
!          sw(mw)=lambda(mw)
!          fw(1,mw)=beta(mw)*r(2,mw)
!          fw(2,mw)=beta(mw)*r(3,mw)
!          fw(3,mw)=beta(mw)*r(2,mw)
!       enddo
      sw1 = lambda(1)
      sw2 = lambda(2)
      sw3 = lambda(3)
      !mw=1
      fw11 = beta(1)*r(2,1)
      fw21 = beta(1)*r(3,1)
      fw31 = beta(1)*r(2,1)
      !mw=2
      fw12 = beta(2)*r(2,2)
      fw22 = beta(2)*r(3,2)
      fw32 = beta(2)*r(2,2)
      !mw=3
      fw13 = beta(3)*r(2,3)
      fw23 = beta(3)*r(3,3)
      fw33 = beta(3)*r(2,3)

      !find transverse components (ie huv jumps).
      ! MODIFIED from 5.3.1 version
!       fw(3,1)=fw(3,1)*vL
!       fw(3,3)=fw(3,3)*vR
!       fw(3,2)= 0.d0
      fw31=fw31*vL
      fw33=fw33*vR
      fw32=0.d0

!       hustar_interface = huL + fw(1,1)   ! = huR - fw(1,3)
!       if (hustar_interface <= 0.0d0) then
!           fw(3,1) = fw(3,1) + (hR*uR*vR - hL*uL*vL - fw(3,1)- fw(3,3))
!         else
!           fw(3,3) = fw(3,3) + (hR*uR*vR - hL*uL*vL - fw(3,1)- fw(3,3))
!       end if
      hustar_interface = huL + fw11   ! = huR - fw(1,3)
      if (hustar_interface <= 0.0d0) then
          fw31 = fw31 + (hR*uR*vR - hL*uL*vL - fw31- fw33)
        else
          fw33 = fw33 + (hR*uR*vR - hL*uL*vL - fw31- fw33)
      end if

      return

      end !subroutine riemann_aug_JCP-------------------------------------------------

!=============================================================================
      subroutine riemanntype(hL,hR,uL,uR,hm,s1m,s2m,rare1,rare2, &
                  maxiter,drytol,g)

      !determine the Riemann structure (wave-type in each family)

      implicit none

      !input
      real(kind=8) hL,hR,uL,uR,drytol,g
      integer maxiter

      !output
      real(kind=8) s1m,s2m
      logical rare1,rare2

      !local
      real(kind=8) hm,u1m,u2m,um,delu
      real(kind=8) h_max,h_min,h0,F_max,F_min,dfdh,F0,slope,gL,gR
      integer iter
      real(kind=8) sqrt_ghL, sqrt_ghR

      !Test for Riemann structure

      h_min=min(hR,hL)
      h_max=max(hR,hL)
      delu=uR-uL

      ! pre-compute square roots:
      sqrt_ghL = sqrt(g*hL)
      sqrt_ghR = sqrt(g*hR)

      if (h_min.le.drytol) then
         hm=0.d0
         um=0.d0
         s1m=uR+uL-2.d0*sqrt_ghR+2.d0*sqrt_ghL
         s2m=uR+uL-2.d0*sqrt_ghR+2.d0*sqrt_ghL
         if (hL.le.0.d0) then
            rare2=.true.
            rare1=.false.
         else
            rare1=.true.
            rare2=.false.
         endif

      else
         F_min= delu+2.d0*(sqrt(g*h_min)-sqrt(g*h_max))
         F_max= delu + &
              (h_max-h_min)*(sqrt(.5d0*g*(h_max+h_min)/(h_max*h_min)))

         if (F_min.gt.0.d0) then !2-rarefactions

            hm=(1.d0/(16.d0*g))* &
                    max(0.d0,-delu+2.d0*(sqrt_ghL+sqrt_ghR))**2
            um=sign(1.d0,hm)*(uL+2.d0*(sqrt_ghL-sqrt(g*hm)))

            s1m=uL+2.d0*sqrt_ghL-3.d0*sqrt(g*hm)
            s2m=uR-2.d0*sqrt_ghR+3.d0*sqrt(g*hm)

            rare1=.true.
            rare2=.true.

         elseif (F_max.le.0.d0) then !2 shocks

            !root finding using a Newton iteration on sqrt(h)===
            h0=h_max
            do iter=1,maxiter
               gL=sqrt(.5d0*g*(1/h0 + 1/hL))
               gR=sqrt(.5d0*g*(1/h0 + 1/hR))
               F0=delu+(h0-hL)*gL + (h0-hR)*gR
               dfdh=gL-g*(h0-hL)/(4.d0*(h0**2)*gL)+ &
                        gR-g*(h0-hR)/(4.d0*(h0**2)*gR)
               slope=2.d0*sqrt(h0)*dfdh
               h0=(sqrt(h0)-F0/slope)**2
            enddo
               hm=h0
               u1m=uL-(hm-hL)*sqrt((.5d0*g)*(1/hm + 1/hL))
               u2m=uR+(hm-hR)*sqrt((.5d0*g)*(1/hm + 1/hR))
               um=.5d0*(u1m+u2m)

               s1m=u1m-sqrt(g*hm)
               s2m=u2m+sqrt(g*hm)
               rare1=.false.
               rare2=.false.

         else !one shock one rarefaction
            h0=h_min

            do iter=1,maxiter
               F0=delu + 2.d0*(sqrt(g*h0)-sqrt(g*h_max)) &
                       + (h0-h_min)*sqrt(.5d0*g*(1/h0+1/h_min))
               slope=(F_max-F0)/(h_max-h_min)
               h0=h0-F0/slope
            enddo

            hm=h0
            if (hL.gt.hR) then
               um=uL+2.d0*sqrt_ghL-2.d0*sqrt(g*hm)
               s1m=uL+2.d0*sqrt_ghL-3.d0*sqrt(g*hm)
               s2m=uL+2.d0*sqrt_ghL-sqrt(g*hm)
               rare1=.true.
               rare2=.false.
            else
               s2m=uR-2.d0*sqrt_ghR+3.d0*sqrt(g*hm)
               s1m=uR-2.d0*sqrt_ghR+sqrt(g*hm)
               um=uR-2.d0*sqrt_ghR+2.d0*sqrt(g*hm)
               rare2=.true.
               rare1=.false.
            endif
         endif
      endif

      return

      end ! subroutine riemanntype----------------------------------------------------------------