!------------------------------------------------------------------------------!
!Compute energy spectrum from saved data produced by euler3d_MPI.f90
!------------------------------------------------------------------------------!
!Omer San
!Oklahoma State University, Stillwater
!CFDLab.org, cfdlab.osu@gmail.com
!Updated: May 15, 2017
!------------------------------------------------------------------------------!

program spec3d
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=96     	!number of processor (nodes x ppn)
integer :: nx,ny,nz   			!global number of data point in x (even, resolution)
real*8,dimension(:,:,:,:),allocatable :: q
real*8,dimension(:,:,:),allocatable:: u,v,w
integer:: i,j,k,myid,kk,ifile,myid2,nzl,iopt
character(80):: charID,snapID,filename,fi2
real*8 :: dx,dy,dz,x0,y0,z0,lx,ly,lz,pi,x,y,z

nx = 512
ny = nx
nz = nx

iopt = 1 ![1]cube 2pi, [2]cube 1 unit
if (iopt.eq.1) then
pi = 4.0d0*datan(1.0d0)
dx = 2.0d0*pi/dfloat(nx)
dy = dx
dz = dx

x0 = 0.0d0
y0 = 0.0d0
z0 = 0.0d0
else
lx = 1.0d0
ly = 1.0d0
lz = 1.0d0

dx = 1.0d0/dfloat(nx)
dy = dx
dz = dx

x0 =-lx/2.0d0
y0 =-ly/2.0d0
z0 =-lz/2.0d0
end if

!Allocate conserved variables
allocate(q(0:nx,0:ny,0:nz,5))

!allocate velocity components for postprocessing
allocate(u(0:nx,0:ny,0:nz))
allocate(v(0:nx,0:ny,0:nz))
allocate(w(0:nx,0:ny,0:nz))

do ifile=nsnap_s,nsnap_e

kk = 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
! Read data file
fi2= "load_"// trim(adjustl(charID)) // '.dat'
open(unit=19, file=fi2)
read(19,*)myid2,nzl
close(19)

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

! Open the file and start reading the data
open(unit=19, file=filename)
do k = 0, nzl
do j = 0, ny
do i = 0, nx
  	read(19,*) q(i,j,k+kk,1), q(i,j,k+kk,2),q(i,j,k+kk,3),q(i,j,k+kk,4),q(i,j,k+kk,5)
end do
end do
end do

close(19)

kk = kk + nzl

end do

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

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z", "r"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1,' k=', nz+1, ' f=point'
do k=0,nz
do j=0,ny
do i=0,nx
	x = x0 - 0.5d0*dx +  dfloat(i)*dx
    y = y0 - 0.5d0*dy +  dfloat(j)*dy
    z = z0 - 0.5d0*dz +  dfloat(k)*dz
write(19,*)x,y,z,q(i,j,k,1)
end do
end do
end do
close(19)

!compute velocity components
do k=0,nz
do j=0,ny
do i=0,nx
  	u(i,j,k)= q(i,j,k,2)/q(i,j,k,1)
    v(i,j,k)= q(i,j,k,3)/q(i,j,k,1)
    w(i,j,k)= q(i,j,k,4)/q(i,j,k,1)
end do
end do
end do

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

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z", "u", "v", "w"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1,' k=', nz+1, ' f=point'
do k=0,nz
do j=0,ny
do i=0,nx
    x = x0 - 0.5d0*dx +  dfloat(i)*dx
    y = y0 - 0.5d0*dy +  dfloat(j)*dy
    z = z0 - 0.5d0*dz +  dfloat(k)*dz
write(19,*)x,y,z,u(i,j,k),v(i,j,k),w(i,j,k)
end do
end do
end do
close(19)

!compute vorticity and Qcriterion field:
!here 6th order compact scheme is used to compute derivatives
call Qcriterion(nx,ny,nz,dx,dy,dz,x0,y0,z0,u,v,w,ifile)

!compute energy spectrum (Kida):
!fast Fourier transform is used
call spectrum3d(nx,ny,nz,u,v,w,ifile)

!compute structure functions:
!both longitudinal and transverse components are computed for second and third order SF
call strfun3d(nx,ny,nz,dy,u,v,w,ifile)

end do

end

!-----------------------------------------------------------------!
!Compute structure functions from 3D velocity field by definition
!Boffetta, Musacchio, PRE 2010
!Kramer et al., PRE 2011
!-----------------------------------------------------------------!
subroutine strfun3d(nx,ny,nz,dh,u,v,w,ifile)
implicit none
integer::nx,ny,nz,ifile
real*8 ::u(0:nx,0:ny,0:nz)
real*8 ::v(0:nx,0:ny,0:nz)
real*8 ::w(0:nx,0:ny,0:nz)
integer::i,j,k,ii,jj,kk,ir,jr,kr
real*8 ::dh,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

    dl2(ii) = 0.0d0
    dt2(ii) = 0.0d0

    dl3(ii) = 0.0d0
    dt3(ii) = 0.0d0

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

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

		dl2(ii)=dl2(ii)+(dabs(u(i+ir,j,k)-u(i,j,k)))**2 !longitudinal
        dt2(ii)=dt2(ii)+(dabs(v(i+ir,j,k)-v(i,j,k)))**2 !transverse
        dt2(ii)=dt2(ii)+(dabs(w(i+ir,j,k)-w(i,j,k)))**2 !transverse

		dl3(ii)=dl3(ii)+(dabs(u(i+ir,j,k)-u(i,j,k)))**3 !longitudinal
        dt3(ii)=dt3(ii)+(dabs(v(i+ir,j,k)-v(i,j,k)))**3 !transverse
        dt3(ii)=dt3(ii)+(dabs(w(i+ir,j,k)-w(i,j,k)))**3 !transverse

	end do
	end do
    end do

end do

do jj=1,ny/2

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

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

		dl2(jj)=dl2(jj)+(dabs(v(i,j+jr,k)-v(i,j,k)))**2 !longitudinal
        dt2(jj)=dt2(jj)+(dabs(u(i,j+jr,k)-u(i,j,k)))**2 !transverse
        dt2(jj)=dt2(jj)+(dabs(w(i,j+jr,k)-w(i,j,k)))**2 !transverse

		dl3(jj)=dl3(jj)+(dabs(v(i,j+jr,k)-v(i,j,k)))**3 !longitudinal
        dt3(jj)=dt3(jj)+(dabs(u(i,j+jr,k)-u(i,j,k)))**3 !transverse
        dt3(jj)=dt3(jj)+(dabs(w(i,j+jr,k)-w(i,j,k)))**3 !transverse

	end do
	end do
    end do

end do

do kk=1,nz/2

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

    	if (k+kk.ge.nz) then
        kr = kk-nz
        else
        kr = kk
        end if

		dl2(kk)=dl2(kk)+(dabs(w(i,j,k+kr)-w(i,j,k)))**2 !longitudinal
        dt2(kk)=dt2(kk)+(dabs(u(i,j,k+kr)-u(i,j,k)))**2 !transverse
        dt2(kk)=dt2(kk)+(dabs(v(i,j,k+kr)-v(i,j,k)))**2 !transverse

		dl3(kk)=dl3(kk)+(dabs(w(i,j,k+kr)-w(i,j,k)))**3 !longitudinal
        dt3(kk)=dt3(kk)+(dabs(u(i,j,k+kr)-u(i,j,k)))**3 !transverse
        dt3(kk)=dt3(kk)+(dabs(v(i,j,k+kr)-v(i,j,k)))**3 !transverse

	end do
	end do
    end do

end do

do jj=1,ny/2

        dl2(jj) = dl2(jj)/dfloat(3*nx*ny*nz)
        dt2(jj) = dt2(jj)/dfloat(6*nx*ny*nz)

        dl3(jj) = dl3(jj)/dfloat(3*nx*ny*nz)
        dt3(jj) = dt3(jj)/dfloat(6*nx*ny*nz)

end do

! Define the file name
filename = "a_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,*)dh*dfloat(jj),dl2(jj)
end do
close(802)

! Define the file name
filename = "a_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,*)dh*dfloat(jj),dt2(jj)
end do
close(802)

! Define the file name
filename = "a_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,*)dh*dfloat(jj),dl3(jj)
end do
close(802)

! Define the file name
filename = "a_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,*)dh*dfloat(jj),dt3(jj)
end do
close(802)

return
end

!-----------------------------------------------------------------!
!Q-criterion
!-----------------------------------------------------------------!
subroutine Qcriterion(nx,ny,nz,dx,dy,dz,x0,y0,z0,u,v,w,ifile)
implicit none
integer::nx,ny,nz,ifile
real*8 ::dx,dy,dz,x0,y0,z0,x,y,z
real*8 ::u(0:nx,0:ny,0:nz)
real*8 ::v(0:nx,0:ny,0:nz)
real*8 ::w(0:nx,0:ny,0:nz)
integer::i,j,k
real*8, dimension (:), allocatable :: aa,bb
real*8,dimension(:,:,:),allocatable:: qc,wa,w1,w2,w3,ux,vx,wx,uy,vy,wy,uz,vz,wz
character(80):: snapID,filename

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

allocate(qc(0:nx,0:ny,0:nz))
allocate(w1(0:nx,0:ny,0:nz))
allocate(w2(0:nx,0:ny,0:nz))
allocate(w3(0:nx,0:ny,0:nz))
allocate(wa(0:nx,0:ny,0:nz))

allocate(ux(0:nx,0:ny,0:nz))
allocate(uy(0:nx,0:ny,0:nz))
allocate(uz(0:nx,0:ny,0:nz))
allocate(vx(0:nx,0:ny,0:nz))
allocate(vy(0:nx,0:ny,0:nz))
allocate(vz(0:nx,0:ny,0:nz))
allocate(wx(0:nx,0:ny,0:nz))
allocate(wy(0:nx,0:ny,0:nz))
allocate(wz(0:nx,0:ny,0:nz))

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

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

! u_z
allocate(aa(0:nz),bb(0:nz))
do j=0,ny
do i=0,nx
	do k=0,nz
	aa(k) = u(i,j,k)
	end do
		call c6dp(aa,bb,dz,nz)
	do k=0,nz
	uz(i,j,k) = bb(k)
	end do
end do
end do
deallocate(aa,bb)

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

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

! v_z
allocate(aa(0:nz),bb(0:nz))
do j=0,ny
do i=0,nx
	do k=0,nz
	aa(k) = v(i,j,k)
	end do
		call c6dp(aa,bb,dz,nz)
	do k=0,nz
	vz(i,j,k) = bb(k)
	end do
end do
end do
deallocate(aa,bb)

! w_x
allocate(aa(0:nx),bb(0:nx))
do k=0,nz
do j=0,ny
	do i=0,nx
	aa(i) = w(i,j,k)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	wx(i,j,k) = bb(i)
	end do
end do
end do
deallocate(aa,bb)

! w_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
do k=0,nz
	do j=0,ny
	aa(j) = w(i,j,k)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	wy(i,j,k) = bb(j)
	end do
end do
end do
deallocate(aa,bb)

! w_z
allocate(aa(0:nz),bb(0:nz))
do j=0,ny
do i=0,nx
	do k=0,nz
	aa(k) = w(i,j,k)
	end do
		call c6dp(aa,bb,dz,nz)
	do k=0,nz
	wz(i,j,k) = bb(k)
	end do
end do
end do
deallocate(aa,bb)

!Compute vorticity
!Q-criterion:qc
!Absolute value of vorticity:wa
do k=0,nz
do j=0,ny
do i=0,nx

  	w1(i,j,k)= wy(i,j,k) - vz(i,j,k)
    w2(i,j,k)= uz(i,j,k) - wx(i,j,k)
    w3(i,j,k)= vx(i,j,k) - uy(i,j,k)

	qc(i,j,k) = -0.5d0*(ux(i,j,k)*ux(i,j,k)+uy(i,j,k)*vx(i,j,k)+uz(i,j,k)*wx(i,j,k) &
                      +vx(i,j,k)*uy(i,j,k)+vy(i,j,k)*vy(i,j,k)+vz(i,j,k)*wy(i,j,k) &
                      +wx(i,j,k)*uz(i,j,k)+wy(i,j,k)*vz(i,j,k)+wz(i,j,k)*wz(i,j,k) )

    wa(i,j,k)=dsqrt(w1(i,j,k)*w1(i,j,k)+w2(i,j,k)*w2(i,j,k)+w3(i,j,k)*w3(i,j,k))
end do
end do
end do

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

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z", "w1","w2","w3"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1,' k=', nz+1, ' f=point'
do k=0,nz
do j=0,ny
do i=0,nx
  	x = x0 - 0.5d0*dx +  dfloat(i)*dx
    y = y0 - 0.5d0*dy +  dfloat(j)*dy
    z = z0 - 0.5d0*dz +  dfloat(k)*dz
write(19,*)x,y,z,w1(i,j,k),w2(i,j,k),w3(i,j,k)
end do
end do
end do
close(19)

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

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z", "Q","w"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1,' k=', nz+1, ' f=point'
do k=0,nz
do j=0,ny
do i=0,nx
  	x = x0 - 0.5d0*dx +  dfloat(i)*dx
    y = y0 - 0.5d0*dy +  dfloat(j)*dy
    z = z0 - 0.5d0*dz +  dfloat(k)*dz
write(19,*)x,y,z,qc(i,j,k),wa(i,j,k)
end do
end do
end do
close(19)

deallocate(qc,wa,w1,w2,w3,ux,vx,wx,uy,vy,wy,uz,vz,wz)

return
end

!-----------------------------------------------------------------!
!Compute vorticity using compact scheme
!-----------------------------------------------------------------!
subroutine vorticity3d(nx,ny,nz,dx,dy,dz,x0,y0,z0,q,ifile)
implicit none
integer::nx,ny,nz,ifile,i,j,k
real*8 ::dx,dy,dz,x0,y0,z0,x,y,z
real*8 ::q(0:nx,0:ny,0:nz,5)
real*8,dimension(:,:,:),allocatable:: w1,w2,w3
real*8,dimension(:), allocatable:: aa,bb
character(80):: snapID,filename

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

allocate(w1(0:nx,0:ny,0:nz))
allocate(w2(0:nx,0:ny,0:nz))
allocate(w3(0:nx,0:ny,0:nz))

! compute vorticity w3
! v_x
allocate(aa(0:nx),bb(0:nx))
do k=0,nz
do j=0,ny
	do i=0,nx
	aa(i) = q(i,j,k,3)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	w3(i,j,k) = bb(i)
	end do
end do
end do
deallocate(aa,bb)

! u_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
  do k=0,nz
	do j=0,ny
	aa(j) = q(i,j,k,2)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	w3(i,j,k) = w3(i,j,k) - bb(j)
	end do
end do
end do
deallocate(aa,bb)

! compute vorticity w2
! u_z
allocate(aa(0:nz),bb(0:nz))
do j=0,ny
do i=0,nx
	do k=0,nz
	aa(k) = q(i,j,k,2)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dz,nz)
	do k=0,nz
	w2(i,j,k) = bb(k)
	end do
end do
end do
deallocate(aa,bb)

! w_x
allocate(aa(0:nx),bb(0:nx))
do k=0,nz
do j=0,ny
	do i=0,nx
	aa(i) = q(i,j,k,4)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dx,nx)
	do i=0,nx
	w2(i,j,k) = w2(i,j,k) - bb(i)
	end do
end do
end do
deallocate(aa,bb)

! compute vorticity w1
! w_y
allocate(aa(0:ny),bb(0:ny))
do i=0,nx
do k=0,nz
	do j=0,ny
	aa(j) = q(i,j,k,4)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dy,ny)
	do j=0,ny
	w1(i,j,k) = bb(j)
	end do
end do
end do
deallocate(aa,bb)

! v_z
allocate(aa(0:nz),bb(0:nz))
do j=0,ny
do i=0,nx
	do k=0,nz
	aa(k) = q(i,j,k,3)/q(i,j,k,1)
	end do
		call c6dp(aa,bb,dz,nz)
	do k=0,nz
	w1(i,j,k) = w1(i,j,k)-bb(k)
	end do
end do
end do
deallocate(aa,bb)

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

open(unit=19, file=filename)
write(19,*) 'variables = "x", "y", "z", "w1","w2","w3"'
write(19,*) 'zone T=','Zone_'// trim(adjustl(snapID)), &
            ' i=', nx+1, ' j=', ny+1,' k=', nz+1, ' f=point'
do k=0,nz
do j=0,ny
do i=0,nx
	x = x0 - 0.5d0*dx +  dfloat(i)*dx
    y = y0 - 0.5d0*dy +  dfloat(j)*dy
    z = z0 - 0.5d0*dz +  dfloat(k)*dz
write(19,*)x,y,z,w1(i,j,k),w2(i,j,k),w3(i,j,k)
end do
end do
end do
close(19)

deallocate(w1,w2,w3)

return
end

!-----------------------------------------------------------------!
!Compute spectrum from by definition of Kida
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spectrum3d(nx,ny,nz,u,v,w,ifile)
implicit none
integer::nx,ny,nz,ifile
real*8 ::u(0:nx,0:ny,0:nz)
real*8 ::v(0:nx,0:ny,0:nz)
real*8 ::w(0:nx,0:ny,0:nz)
integer::i,j,k,p,np
real*8 ::kx(0:nx),ky(0:ny),kz(0:nz)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,ae
real*8,dimension(:,:,:),allocatable::ee
integer,parameter::ndim=3
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*nz))
allocate(data2d(2*nx*ny*nz))
allocate(data3d(2*nx*ny*nz))

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

!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

p=0
do k=0,nz/2
kz(k) = dfloat(p)
p=p+1
end do
p=-nz/2+1
do k=nz/2+1,nz-1
kz(k) = dfloat(p)
p=p+1
end do

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

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

temp=1.0d0/dfloat(nx*ny*nz)

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

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

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

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

allocate(ae(np))

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

! Define the file name
filename = "a_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="a_spectrum_k53.plt")
write(15,*) 'variables ="k","E(k)"'
write(15,*)2.0d0, 1.0d1
write(15,*)2.0d2, 1.0d1*1.0d2**(-5.0d0/3.0d0)
close(15)

deallocate(data1d,data2d,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute spectrum from by definition of Kida
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spectrum3d_old(nx,ny,nz,q,ifile)
implicit none
integer::nx,ny,nz,ifile
real*8 ::q(0:nx,0:ny,0:nz,5)
integer::i,j,k,p,np
real*8 ::kx(0:nx),ky(0:ny),kz(0:nz)
real*8,dimension(:),allocatable:: data1d,data2d,data3d,ae
real*8,dimension(:,:,:),allocatable::ee
integer,parameter::ndim=3
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*nz))
allocate(data2d(2*nx*ny*nz))
allocate(data3d(2*nx*ny*nz))

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

!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

p=0
do k=0,nz/2
kz(k) = dfloat(p)
p=p+1
end do
p=-nz/2+1
do k=nz/2+1,nz-1
kz(k) = dfloat(p)
p=p+1
end do

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

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

temp=1.0d0/dfloat(nx*ny*nz)

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

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

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

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

allocate(ae(np))

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

! Define the file name
filename = "a_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="a_spectrum_k53.plt")
write(15,*) 'variables ="k","E(k)"'
write(15,*)2.0d0, 1.0d1
write(15,*)2.0d2, 1.0d1*1.0d2**(-5.0d0/3.0d0)
close(15)

deallocate(data1d,data2d,ee,ae)

return
end

!-----------------------------------------------------------------!
!Compute spectrum by definition of Kida (avaraged version)
!S Kida, Y. Murakami, et al. 1990
!-----------------------------------------------------------------!
subroutine spectrum_ave(nx,ny,nz,q,ifile)
implicit none
integer::nx,ny,nz,i,j,k,p,nt,ic1,ifile
real*8 ::temp,kk,pi
real*8 ::q(0:nx,0:ny,0:nz,5)
integer,parameter:: ndim=3
integer::nn(ndim),isign
real*8,parameter:: tiny=1.0d-10
integer::kx(0:nx),ky(0:ny),kz(0:nz)
complex*16,dimension(:,:,:),allocatable::uf,vf,wf
real*8,dimension(:,:,:),allocatable::es
real*8,dimension(:),allocatable::aes1
real*8,dimension(:),allocatable ::data1d
character(80):: snapID,filename

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

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

temp=1.0d0/dfloat(nx*ny*nz)

pi=4.0d0*datan(1.0d0)

!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

p=0
do k=0,nz/2
kz(k) = dfloat(p)
p=p+1
end do
p=-nz/2+1
do k=nz/2+1,nz-1
kz(k) = dfloat(p)
p=p+1
end do

allocate(data1d(2*nx*ny*nz))
allocate(uf(0:nx,0:ny,0:nz))
allocate(vf(0:nx,0:ny,0:nz))
allocate(wf(0:nx,0:ny,0:nz))

!finding fourier coefficients of u
!inverse fourier transform
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =q(i,j,k,2)/q(i,j,k,1)
data1d(p+1)=0.0d0
p=p+2
end do
end do
end do

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

p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
uf(i,j,k)=dcmplx(data1d(p)*temp,data1d(p+1)*temp)
p=p+2
end do
end do
end do

!finding fourier coefficients of v
!invese fourier transform
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =q(i,j,k,3)/q(i,j,k,1)
data1d(p+1)=0.0d0
p=p+2
end do
end do
end do

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

p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
vf(i,j,k)=dcmplx(data1d(p)*temp,data1d(p+1)*temp)
p=p+2
end do
end do
end do

!finding fourier coefficients of w
!invese fourier transform
p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
data1d(p)  =q(i,j,k,4)/q(i,j,k,1)
data1d(p+1)=0.0d0
p=p+2
end do
end do
end do

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

p=1
do k=0,nz-1
do j=0,ny-1
do i=0,nx-1
wf(i,j,k)=dcmplx(data1d(p)*temp,data1d(p+1)*temp)
p=p+2
end do
end do
end do

!Compute energy spectrum:es

allocate(es(0:nx,0:ny,0:nz))

do k=0,nz-1
do j=0,ny-1
do i=0,nx-1

es(i,j,k)=0.5d0*dreal(dconjg(uf(i,j,k))*uf(i,j,k) &
                     +dconjg(vf(i,j,k))*vf(i,j,k) &
			         +dconjg(wf(i,j,k))*wf(i,j,k) )

end do
end do
end do

nt = nint(dsqrt(dfloat((kx(nx/2))**2 + (ky(ny/2))**2 + (kz(nz/2))**2)))

allocate(aes1(nt))

!averaging
do p=1,nt
	aes1(p)=0.0d0
	ic1=0
	do k=0,nz-1
	do j=0,ny-1
	do i=0,nx-1
		kk=dsqrt(dfloat(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))
		if (kk.ge.(dfloat(p)-0.5d0).and.kk.lt.(dfloat(p)+0.5d0)) then
		ic1=ic1+1
		aes1(p)=aes1(p)+es(i,j,k)
		end if
	end do
	end do
	end do
	aes1(p)=aes1(p)/(dfloat(ic1)+tiny)*(4.0d0*pi*(dfloat(p)*dfloat(p)))
end do

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

open(unit=800, file=filename)
write(800,*)'variables ="k","E(k)"'
do p=1,nt
write(800,*)p,aes1(p)
end do
close(800)

deallocate(uf,vf,wf,es,aes1,data1d)

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


program forall1
implicit none
! Only for Syntax check

!>>>>>>>>>>>>> Single line statments <<<<<<<<<<<<<<
    FORALL (i=1:n) A(i,i) = B(i)
    forall (i=1:n:3, j=1:n:5) A(i,j) = SIN(A(j,i))
    forall (i=1:n, j=1:n, i/=j) A(i,j) = REAL(i+j)
    forall (i=1:n, j=1:m, A(i,j).NE.0) &
           A(i,j) = 1/A(i,j)
    forall (i=1:1000, j=1:1000, i /= j) A(i,j) = A(j,i)

!>>>>>>>>>>>>> Multipe line statements <<<<<<<<<<<<<<
    forall (j = 1:n) shared(i) local(x) default(none)
        forall (i=1:j) A(i,j) = B(i)
    end forall

    forall (i = 1:N) reduce(*: s)
        s = s + a(i)
    end forall

    FORALL(i = 3:N + 1, j = 3:N + 1)
        C(i, j) = C(i, j + 2) + C(i, j - 2)
        D(i, j) = C(i, j) + C(i + 2, j) + C(i - 2, j)
    end FORALL

    forall (x=1:100, J(x)>0)
        where (I(x,:)<0)
            I(x,:)=0
        elsewhere
            I(x,:)=1
        end where
    end forall

    outer: forall (i=1:100)
        inner: forall (j=1:100, i.NE.j)
            A(i,j) = A(j,i)
        end forall inner
    end forall outer
end program


module covlocal
!$$$  module documentation block
!
! module: covlocal                     functions for Gaspari-Cohn localization,
!                                      blending northern, tropical and southern
!                                      hemisphere parameter values.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract: two functions, one defining the Gaspari-Cohn polynomial for
!  compact localization (taper) and one to smoothly blend parameter
!  values defined separately for the northern hemisphere, southern
!  hemisphere and tropical regions as a function of latitude.
!
! Public Functions:
!  taper: Compute the localization function defined by Gaspari and Cohn, 1999, QJRMS,
!   p. 723-757, eqn 4.10.
!  latval: blend parameters defined as separate NH, SH and tropical constants.
!   The blending is done linearly in latitude band defined by the
!   parameters latbound and delat.
!
! Public Variables: None
!
! program history log:
!   2009-02-23  Initial version.
!
! attributes:
!   language: f95
!
!$$$

use kinds, only : r_single

private
public :: taper, latval

real(r_single) a1,a2,a3,a4,a5,a6,a7,a8,a9
parameter(a1 = -8.0_r_single)
parameter(a2 = 8.0_r_single)
parameter(a3 = 5.0_r_single)
parameter(a4 = 20.0_r_single/3.0_r_single)
parameter(a5 = 1.0_r_single)
parameter(a6 = 8.0_r_single/3.0_r_single)
parameter(a7 = -10.0_r_single)
parameter(a8 =  4.0_r_single)
parameter(a9 = -1.0_r_single/3.0_r_single)

contains

real(r_single) function taper(r)
 ! Gaspari-Cohn taper function.
 ! r should be positive, and normalized so taper = 0 at r = 1
 ! very close to exp(-(r/c)**2), where c = 0.388
 implicit none
 real(r_single), intent(in) :: r
 if(r < a5)then
   if(r > 0.5_r_single)then
      taper = ( ( ( ( a6*r -a2 )*r +a3 )*r +a4 )*r +a7)*r + a8 + a9/r
   else
      taper = ( ( ( a1*r +a2)*r +a3 )*r -a4)*r*r + a5
   end if
 else
    taper = 0._r_single
 end if
end function taper

real(r_single) function latval(deglat,valnh,valtr,valsh)
 ! blend valnh, valtr and valsh (nh, tropical and sh values)
 ! so they vary linearly from one to another in the latitude
 ! bands defined by latbound and delat.
 ! Inputs:
 !  delat: latitude (in degrees)
 !  valnh,valtr,valsh: NH, tropical and SH parameter values.
 ! Returns:  the parameter value corresponding the specified
 !           latitude.
 use params, only: latboundpp,latboundpm,latboundmp,latboundmm, delatinv
 !  latbound:  the latitude that defines the poleward extent
 !             of the "tropics".
 !  delat:  the transition zone (in degree latitude) over
 !          which the parameters change linearly from one
 !          value to another.
 implicit none
 real(r_single), intent(in) :: deglat,valnh,valtr,valsh
 if (deglat > latboundpp) then
    latval = valnh
 else if (deglat >= latboundpm) then
    latval = ((latboundpp-deglat)*valtr + (deglat-latboundpm)*valnh)*delatinv
 else if (deglat > latboundmp) then
    latval = valtr
 else if (deglat >= latboundmm) then
    latval = ((latboundpp+deglat)*valtr + (-deglat+latboundmp)*valsh)*delatinv
 else
    latval = valsh
 end if
end function latval

end module covlocal


    !use crop2mlModules
        REAL:: tt, maxVernaProg, dLverna, primordno, minLeafNumber, potlfno
        IF ((isVernalizable==1) .AND. (vernaprog < 1)) THEN
            tt = deltaTT
            IF ((tt >= minTvern) .AND. (TT <= intTvern)) THEN
                vernaprog = vernaprog + vAI * tt + vBEE
            END IF
            IF (tt > intTvern) THEN
                maxVernaProg = vAI * intTvern + vBEE
                dLverna = MAX(minDL, MIN(maxDL, dayLength))
                vernaprog =vernaprog + MAX(0.0, maxVernaProg * (1 + ((intTvern - tt) / (maxTvern - intTvern))&
                    * ((dLverna - minDL) / (maxDL - minDL))))
            END IF
            primordno = 2.0 * leafNumber + pNini
            minLeafNumber = minFinalNumber
            IF ((vernaprog >= 1.0) .OR. (primordno >= aMXLFNO)) THEN
                minFinalNumber = MAX(primordno, minFinalNumber)
                CALL AddToListChar(calendarMoments, "EndVernalisation")
                CALL AddToList(calendarCumuls, cumulTT)
                CALL AddToListChar(calendarDates, currentdate)
            ELSE
                potlfno = aMXLFNO - (aMXLFNO - minLeafNumber) * vernaprog
                IF (primordno >= potlfno) THEN
                    minFinalNumber = MAX((potlfno + primordno) / 2.0, minFinalNumber)
                    CALL AddToListChar(calendarMoments,"EndVernalisation")
                    CALL AddToList(calendarCumuls,cumulTT)
                    CALL AddToListChar(calendarDates,currentdate)
                    vernaprog = MAX(1, INT(vernaprog))
                END IF
            END IF
        END IF


subroutine grid
use lib_array
use para
implicit none
integer*8 i,j,k
real*8:: x(ndim),y(ndim),z(ndim)
call linspace(-dim/2.d0,dim/2.d0,x)
call linspace(-dim/2.d0,dim/2.d0,y)
call linspace(-dim/2.d0,dim/2.d0,z)
!x=x+x0
!y=y+y0
!z=z+z0
!!$OMP PARALLEL DO default(shared) PRIVATE(I,j,k),SCHEDULE(dynamic,8)
!$OMP PARALLEL DO default(shared) PRIVATE(I,j,k),SCHEDULE(auto)
do i=1,ndim
	do j=1,ndim
		do k=1,ndim
			grids(1,i,j,k)=x(i)
			grids(2,i,j,k)=y(j)
			grids(3,i,j,k)=z(k)
			cyl(1,i,j,k)=dsqrt(y(j)**2d0+x(i)**2d0)
			cyl(2,i,j,k)=datan2(y(j),x(i))
			cyl(3,i,j,k)=z(k)
			call integu(grids(4,i,j,k),i,j,k)
!			write(*,'(4e)') grids(:,i,j,k)
		enddo
	enddo
enddo
!$OMP END PARALLEL DO
do i=1,ndim
    do j=1,ndim
        do k=1,ndim
            write(*,'(4e)') grids(:,i,j,k)
        enddo
    enddo
enddo

endsubroutine grid


!	Scale function
!	dimtrans is the dimension of the transformation.
!	theta is the argument.
function transform(dimtrans,theta)
use transset
implicit none
integer,intent(in)::dimtrans
real (kind=8),intent(in)::theta(:)
real(kind=8)::transform(dimtrans)
!	elementin is the source element.
!	elementout is the output element.
!	Component counter is i.
!	j counts degrees.
!	k and kk are used to find coefficients of polynomials.
integer::elementin,elementout,i,j,k,kk
!	bas is the base.
!	pol is the polynomial value.
!	th is the element of theta used in the component.
!	wt is the component weight.
real(kind=8)::bas,pol,th,wt
transform=0.0_8
kk=1

do i=1,components
	k=kk
	kk=kk+degrees(i)+1

	elementout=elementsout(i)
	th=dot_product(inweights(:,i),theta)
	wt=1.0_8
	!	See if th is within bounds.
	if(lbmasks(i)) then
		if(lbs(i)>th) cycle
	end if
	if(ubmasks(i))then
		if(ubs(i)<th)cycle
	end if
	if(th==lbs(i).or.th==ubs(i))wt=0.5_8
!	Polynomial computation.
	pol=0.0_8
	bas=bases(i)
	do j=0,degrees(i)
		pol=pol*(th-bas)+coeff(kk-j-1)
	end do
!	Add component.
	transform(elementout)=transform(elementout)+wt*pol
end do

end function transform


c     program DRDNQSOL
c>> 1996-06-21 DRDNQSOL Krogh  Changes for C conversion.
c>> 1994-11-02 DRDNQSOL Krogh  Changes to use M77CON
c>> 1992-04-15 DRDNQSOL CLL.
c>> 1992-01-14 CLL.
c     Demo driver for DNQSOL.  Also using DCKDER.
c     Expected solution vector:  0.9000518     1.0001835     1.0945009
c     ------------------------------------------------------------------
c--D replaces "?": DR?NQSOL, ?NQSOL, ?NRM2, ?CKDER, ?NQFJ
c     ------------------------------------------------------------------
      external D1MACH, DNQFJ, DNRM2
      integer I, IMAX, IOPT(5), J, JMAX, LWA, M, MODE, N, NMAX
      parameter(NMAX = 3, LWA = 3+(15*NMAX+3*NMAX*NMAX)/2 )
      double precision D1MACH, DNRM2
      double precision FJAC(NMAX,NMAX), FNORM, FVEC(NMAX)
      double precision TEST(NMAX,NMAX), TOL, TSTMAX, WA(LWA), X(NMAX)
      data N / NMAX /
c     ------------------------------------------------------------------
      IOPT(4) = 0
      TOL = sqrt(D1MACH(4))
      X(1) = 3.0D0
      X(2) = 3.0D0
      X(3) = 3.0D0
      print*,
     *  'Program DRDNQSOL.  Demo driver for DNQSOL.  Also using DCKDER.'

c     ------------------------------------------------------------------
c               Using DCKDER to check derivative computation.
c     ------------------------------------------------------------------
      print'(/'' Using DCKDER to check derivative computation.'')'
      M  = N
      call DNQFJ(N, X, FVEC ,FJAC, 2)
      MODE = 1
   10 continue
      call DCKDER(MODE, M, N, X, FVEC, FJAC, NMAX, TEST,
     *            IMAX, JMAX, TSTMAX)
      if(MODE .eq. 2) then
         call DNQFJ(N, X, FVEC ,FJAC, 1)
         go to 10
      endif
      call DNQFJ(N, X, FVEC ,FJAC, 1)
      print'(/11x,''X(J) ='',5g11.3:/(17x,5g11.3))',(X(J),J=1,N)
      print'(/1x,''  I    FVEC(I)  '',
     *   '' .....................FJAC(I,J)........................''/)'
      do 20 I = 1,M
         print'(1x,i3,1x,g11.3,1x,5g11.3:/(17x,5g11.3))',
     *         I,FVEC(I),(FJAC(I,J),J=1,N)
   20 continue
      print'(/1x,''TEST(,):''/)'
      do 30 I = 1,M
         print'(1x,i3,13x,5g11.3:/(17x,5g11.3))',I,(TEST(I,J),J=1,N)
   30 continue
      print'(/1x,''IMAX ='',i3,'',    JMAX ='',i3,'',    TSTMAX ='',
     *   g11.3)', IMAX,JMAX,TSTMAX

c     ------------------------------------------------------------------
c           Using DNQSOL to solve system of nonlinear equations.
c     ------------------------------------------------------------------
      print
     *  '(/'' Using DNQSOL to solve system of nonlinear equations.'')'

      call DNQSOL(DNQFJ, N, X, FVEC, TOL, IOPT, WA, LWA)

      FNORM = DNRM2(N,FVEC,1)
c++ CODE for ~.C. is active
      print'('' Termination status:  '',i6/'' NFEV, NJEV:          '',
     * 2i6/ '' Final residual norm: '',g14.3/'' Final X():           ''
     * /(8x,4f14.7))',  IOPT(1), IOPT(2), IOPT(3),
     * FNORM, (X(J), J = 1, N)
c++ CODE for .C. is inactive
c%%   printf( " Termination status:  %6ld\n NFEV, NJEV:          "
c%%   "%6ld%6ld\n Final residual norm: %14.3g\n Final X():           ",
c%%      Iopt[1], Iopt[2], Iopt[3], fnorm);
c%%   for (j = 0; j < n; j+=4){
c%%      printf( "\n        " );
c%%      for (i = j; i < (j < n - 3 ? j + 4 : n); i++)
c%%         printf( "%14.7f", x[i] );}
c%%   printf( "\n" );
c++ END
      stop
      end
c     ==================================================================
      subroutine DNQFJ(N, X, FVEC ,FJAC, IFLAG)
c>> 1992-01-14 CLL.
c     Sample 3-dimensional function of 3 variables for demo of solution
c     of a system of nonlinear equations.
c     ------------------------------------------------------------------
      integer I, IFLAG, N
      double precision C1(3), C2(3), C3(3), FJAC(N,N), FVEC(N)
      double precision TERM(3), X(N)
      data C1 / -1.0d0,  2.0d0,  2.0d0 /
      data C2 /  2.0d0, -1.0d0,  2.0d0 /
      data C3 /  2.0d0,  2.0d0, -1.0d0 /
      data TERM / 5.01d0, 5.85d0, 8.88d0 /
c     ------------------------------------------------------------------
      if (IFLAG .eq. 1) then
c                                        Compute function vector.
         do 10 I = 1,N
            FVEC(I) = exp(C1(I)*X(1)) + sinh(C2(I)*X(2)) +
     *                tanh(C3(I)*X(3)) - TERM(I)
   10    continue
      elseif (IFLAG .eq. 2) then
c                                        Compute Jacobian matrix.
         do 40 I = 1, N
            FJAC(I,1) = exp(C1(I)*X(1)) * C1(I)
            FJAC(I,2) = cosh(C2(I)*X(2)) * C2(I)
            FJAC(I,3) = (1.0d0/cosh(C3(I)*X(3)))**2 * C3(I)
  40     continue
      endif
      return
      end


	SUBROUTINE
     . SURVRELH
     .(xALPHA,POWER,xM1,xA,xF,xN,xM,ALT,M2L,M2H,RL,RH)
!MS$ATTRIBUTES REFERENCE :: ALT
!MS$ATTRIBUTES REFERENCE :: M2L
!MS$ATTRIBUTES REFERENCE :: M2H
!MS$ATTRIBUTES REFERENCE :: RL
!MS$ATTRIBUTES REFERENCE :: RH
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Determine the relative hazard for survival data.
C
C  Input (provided by user):
C	ALPHA	Type I error probability (two tailed)
C	POWER	The desired statistical power
C	M1	Median survival time on control treatment
C	A	The accrual time during which patients are recruited into
C		the study
C	F	Additional follow-up time after the end of patient
C		recruitment
C	N	Number of experimental patients
C	M	Ratio of control to experimental patients
C  Output:
C     ALT=1  both low and high solutions found
C     ALT=2  only low solution found
C     ALT=3  only high solution found
C	M2L,M2H	The median survival times on the experimental treatment
C		that can be detected with power POWER given N experimental
C		patients, M controls per experimental patient, and
C		type I error probability ALPHA
C	RL = M2L/M1
C	RH = M2H/M1
C
C  Reference:
C	Schoenfeld DA, Richter JR: "Nomograms for Calculating the
C	Number of Patients Needed for a Clinical Trial With Survival
C	as an Endpoint" Biometrics 1982; 38: 163-170.
C
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Designed by William Dupont
C   .	Schoenfeld and Richter define BETA to equal the study power
C	    rather than the type II error.  Otherwise the notation used
C	    in this program is analogous to that used by these authors.
C
C-Declarations----------------------------------------------------------
C
C  Arguments
C
	REAL xALPHA,POWER,xM1,xA,xF,xN,xM,M2L,M2H,RL,RH
	INTEGER	ALT
C
C  Locals
C
	REAL E1,EPS,Y1,Y2, xBETA, FY
	INTEGER ERRORL,ERRORH
	INTEGER MAXFN
C
C    Declare function to be solved for power.
C
	EXTERNAL SURVFUNC1
	REAL SURVFUNC1
C
C    Data passed in common to functions.
C
	REAL ALPHA,BETA,M1,A,F,N,M,ZALPHA,ZBETA
	COMMON /SURVCOM1/ ALPHA,BETA,M1,A,F,N,M
	COMMON /SURVCOM2/ ZALPHA, ZBETA
C
C-Code------------------------------------------------------------------
C
C    BETA is 1-power.
C
	xBETA=1.-POWER
C
C    Load the common data area.
C
	ALPHA=xALPHA
	BETA=xBETA
	M1=xM1
	A=xA
	F=xF
	N=xN
	M=xM
C
C    Here is an insufficient attempt to give A a reasonable value relative to F.
C
	IF (A.EQ.0.) A=0.00004*F
C
C    The evaluation of the function will halt if the value of the function
C    is less than EPS.
C
	EPS=0.001*MIN(1.,M1)
C
C    The evaluation of the function will halt if two successive
C    approximations differ by less than E1.
C
	E1=0.001*MIN(1.,M1)
C
C    Set initial end points for lower end point.
C
	Y1=EPS
	Y2=M1-EPS
C
C    Allow up to MAXFN function evaluations.
C
	MAXFN=100
C
C    Solve the equation for the lower solution.
C
	CALL BISEC(Y1,Y2,EPS,E1,SURVFUNC1,M2L,ERRORL)
C
C    Calculate the relative risk.
C
	RL=M2L/M1
C
C    Set the interval in which we will search for the upper M2.  This
C    interval is:  just_over_M1 ... some_large_value.
C
      Y1=M1+EPS
C
C    Set initial end points for high end point.
C
C	Y1=M1+EPS
C	Y2=MAX(10000.,1000.*M1)
C
C    06-Oct-1997 : a new way to set the upper end of this upper interval:
C    look in the range F+A to F+A+(100*M1) for when the function goes negative.
C    Make this point the end of the upper interval in which to search for the
C    upper zero.  If no such point is found the assume that there is no
C    upper solution.
C
	DO Y2=F+A , F+A+(100.*M1)
	    FY=SURVFUNC1(Y2)
	    IF (FY.LT.0) GOTO 110
	END DO
C
C    If we fall out of this loop then we will not try to
C    find an upper solution.  In this case force the state
C    where we indicate that no upper solution was found.
C
	ERRORH=1
	GO TO 1112
C
C    Solve the equation for the upper solution.
C
110	CONTINUE
	CALL BISEC(Y1,Y2,EPS,E1,SURVFUNC1,M2H,ERRORH)
C
C    Calculate the relative risk.
C
	RH=M2H/M1
C
C    Report the results.
C
C    Write first to the terminal screen.
C
1112	CONTINUE
	IF (ERRORL.EQ.0 .AND. ERRORH.EQ.0) THEN
C
C    Found both low and high solutions (M2L and M2H, RL and RH).
C
	    ALT=1
	ELSE IF (ERRORL.EQ.0 .AND. ERRORH.EQ.1) THEN
C
C    Found low solution only (M2L, RL).
C
		ALT=2
	ELSE IF (ERRORL.EQ.1 .AND. ERRORH.EQ.0) THEN
C
C    Found high solution only (M2H, RH).
C
		ALT=3
	ELSE
		ALT=-99
	END IF
	RETURN
	END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                   !!
!!                   GNU General Public License                      !!
!!                                                                   !!
!! This file is part of the Flexible Modeling System (FMS).          !!
!!                                                                   !!
!! FMS is free software; you can redistribute it and/or modify       !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation.             !!
!!                                                                   !!
!! FMS is distributed in the hope that it will be useful,            !!
!! but WITHOUT ANY WARRANTY; without even the implied warranty of    !!
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     !!
!! GNU General Public License for more details.                      !!
!!                                                                   !!
!! You should have received a copy of the GNU General Public License !!
!! along with FMS; if not, write to:                                 !!
!!          Free Software Foundation, Inc.                           !!
!!          59 Temple Place, Suite 330                               !!
!!          Boston, MA  02111-1307  USA                              !!
!! or see:                                                           !!
!!          http://www.gnu.org/licenses/gpl.txt                      !!
!!                                                                   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module fft99_mod

use types_mod, only : r8
use constants_mod, only: pi

implicit none
private

public :: fft99, fft991, set99

contains

!##########################################################################

    subroutine fft99 (a,work,trigs,ifax,inc,jump,n,lot,isign)

! purpose      performs multiple fast fourier transforms.  this package
!              will perform a number of simultaneous real/half-complex
!              periodic fourier transforms or corresponding inverse
!              transforms, i.e.  given a set of real data vectors, the
!              package returns a set of 'half-complex' fourier
!              coefficient vectors, or vice versa.  the length of the
!              transforms must be an even number greater than 4 that has
!              no other factors except possibly powers of 2, 3, and 5.
!              this is an all-fortran version of a optimized routine
!              fft99 written for xmp/ymps by dr. clive temperton of
!              ecmwf.
!
!              the package fft99f contains several user-level routines:
!
!            subroutine set99
!                an initialization routine that must be called once
!                before a sequence of calls to the fft routines
!                (provided that n is not changed).
!
!            subroutines fft99 and fft991
!                two fft routines that return slightly different
!                arrangements of the data in gridpoint space.
!
! usage        let n be of the form 2**p * 3**q * 5**r, where p .ge. 1,
!              q .ge. 0, and r .ge. 0.  then a typical sequence of
!              calls to transform a given set of real vectors of length
!              n to a set of 'half-complex' fourier coefficient vectors
!              of length n is
!
!                   dimension ifax(13),trigs(3*n/2+1),a(m*(n+2)),
!                  +          work(m*(n+1))
!
!                   call set99 (trigs, ifax, n)
!                   call fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
!
!              see the individual write-ups for set99, fft99, and
!              fft991 below, for a detailed description of the
!              arguments.
!
! history      the package was written by clive temperton at ecmwf in
!              november, 1978.  it was modified, documented, and tested
!              for ncar by russ rew in september, 1980.
!
!-----------------------------------------------------------------------
!
! subroutine set99 (trigs, ifax, n)
!
! purpose      a set-up routine for fft99 and fft991.  it need only be
!              called once before a sequence of calls to the fft
!              routines (provided that n is not changed).
!
! argument     ifax(13),trigs(3*n/2+1)
! dimensions
!
! arguments
!
! on input     trigs
!               a floating point array of dimension 3*n/2 if n/2 is
!               even, or 3*n/2+1 if n/2 is odd.
!
!              ifax
!               an integer array.  the number of elements actually used
!               will depend on the factorization of n.  dimensioning
!               ifax for 13 suffices for all n less than a million.
!
!              n
!               an even number greater than 4 that has no prime factor
!               greater than 5.  n is the length of the transforms (see
!               the documentation for fft99 and fft991 for the
!               definitions of the transforms).
!
! on output    ifax
!               contains the factorization of n/2.  ifax(1) is the
!               number of factors, and the factors themselves are stored
!               in ifax(2),ifax(3),...  if set99 is called with n odd,
!               or if n has any prime factors greater than 5, ifax(1)
!               is set to -99.
!
!              trigs
!               an array of trigonometric function values subsequently
!               used by the fft routines.
!
!-----------------------------------------------------------------------
!
! subroutine fft991 (a,work,trigs,ifax,inc,jump,n,m,isign)
!                       and
! subroutine fft99 (a,work,trigs,ifax,inc,jump,n,m,isign)
!
! purpose      perform a number of simultaneous real/half-complex
!              periodic fourier transforms or corresponding inverse
!              transforms, using ordinary spatial order of gridpoint
!              values (fft991) or explicit cyclic continuity in the
!              gridpoint values (fft99).  given a set
!              of real data vectors, the package returns a set of
!              'half-complex' fourier coefficient vectors, or vice
!              versa.  the length of the transforms must be an even
!              number that has no other factors except possibly powers
!              of 2, 3, and 5.  this is an all-fortran version of
!              optimized routine fft991 written for xmp/ymps by
!              dr. clive temperton of ecmwf.
!
! argument     a(m*(n+2)), work(m*(n+1)), trigs(3*n/2+1), ifax(13)
! dimensions
!
! arguments
!
! on input     a
!               an array of length m*(n+2) containing the input data
!               or coefficient vectors.  this array is overwritten by
!               the results.
!
!              work
!               a work array of dimension m*(n+1)
!
!              trigs
!               an array set up by set99, which must be called first.
!
!              ifax
!               an array set up by set99, which must be called first.
!
!              inc
!               the increment (in words) between successive elements of
!               each data or coefficient vector (e.g.  inc=1 for
!               consecutively stored data).
!
!              jump
!               the increment (in words) between the first elements of
!               successive data or coefficient vectors.  on crays,
!               try to arrange data so that jump is not a multiple of 8
!               (to avoid memory bank conflicts).  for clarification of
!               inc and jump, see the examples below.
!
!              n
!               the length of each transform (see definition of
!               transforms, below).
!
!              m
!               the number of transforms to be done simultaneously.
!
!              isign
!               = +1 for a transform from fourier coefficients to
!                    gridpoint values.
!               = -1 for a transform from gridpoint values to fourier
!                    coefficients.
!
! on output    a
!               if isign = +1, and m coefficient vectors are supplied
!               each containing the sequence:
!
!               a(0),b(0),a(1),b(1),...,a(n/2),b(n/2)  (n+2 values)
!
!               then the result consists of m data vectors each
!               containing the corresponding n+2 gridpoint values:
!
!               for fft991, x(0), x(1), x(2),...,x(n-1),0,0.
!               for fft99, x(n-1),x(0),x(1),x(2),...,x(n-1),x(0).
!                   (explicit cyclic continuity)
!
!               when isign = +1, the transform is defined by:
!                 x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!                 where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!                 and i=sqrt (-1)
!
!               if isign = -1, and m data vectors are supplied each
!               containing a sequence of gridpoint values x(j) as
!               defined above, then the result consists of m vectors
!               each containing the corresponding fourier cofficients
!               a(k), b(k), 0 .le. k .le n/2.
!
!               when isign = -1, the inverse transform is defined by:
!                 c(k)=(1/n)*sum(j=0,...,n-1)(x(j)*exp(-2*i*j*k*pi/n))
!                 where c(k)=a(k)+i*b(k) and i=sqrt(-1)
!
!               a call with isign=+1 followed by a call with isign=-1
!               (or vice versa) returns the original data.
!
!               note: the fact that the gridpoint values x(j) are real
!               implies that b(0)=b(n/2)=0.  for a call with isign=+1,
!               it is not actually necessary to supply these zeros.
!
! examples      given 19 data vectors each of length 64 (+2 for explicit
!               cyclic continuity), compute the corresponding vectors of
!               fourier coefficients.  the data may, for example, be
!               arranged like this:
!
! first data   a(1)=    . . .                a(66)=             a(70)
! vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
!
! second data  a(71)=   . . .                                  a(140)
! vector       x(63) x(0) x(1) x(2) ... x(63) x(0)  (4 empty locations)
!
!               and so on.  here inc=1, jump=70, n=64, m=19, isign=-1,
!               and fft99 should be used (because of the explicit cyclic
!               continuity).
!
!               alternatively the data may be arranged like this:
!
!                first         second                          last
!                data          data                            data
!                vector        vector                          vector
!
!                 a(1)=         a(2)=                           a(19)=
!
!                 x(63)         x(63)       . . .               x(63)
!        a(20)=   x(0)          x(0)        . . .               x(0)
!        a(39)=   x(1)          x(1)        . . .               x(1)
!                  .             .                               .
!                  .             .                               .
!                  .             .                               .
!
!               in which case we have inc=19, jump=1, and the remaining
!               parameters are the same as before.  in either case, each
!               coefficient vector overwrites the corresponding input
!               data vector.
!
!-----------------------------------------------------------------------
    integer, intent(in)    :: inc,jump,n,lot,isign
    integer, intent(inout) :: ifax(:)
    real(r8),    intent(in)    :: trigs(:)
    real(r8),    intent(inout) :: a(*),work(*)

!     dimension a(n),work(n),trigs(n),ifax(1)
!
!     subroutine "fft99" - multiple fast real periodic transform
!     corresponding to old scalar routine fft9
!     procedure used to convert to half-length complex transform
!     is given by cooley, lewis and welch (j. sound vib., vol. 12
!     (1970), 315-337)
!
!     a is the array containing input and output data
!     work is an area of size (n+1)*lot
!     trigs is a previously prepared list of trig function values
!     ifax is a previously prepared list of factors of n/2
!     inc is the increment within each data 'vector'
!         (e.g. inc=1 for consecutively stored data)
!     jump is the increment between the start of each data vector
!     n is the length of the data vectors
!     lot is the number of data vectors
!     isign = +1 for transform from spectral to gridpoint
!           = -1 for transform from gridpoint to spectral
!
!     ordering of coefficients:
!         a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2)
!         where b(0)=b(n/2)=0; (n+2) locations required
!
!     ordering of data:
!         x(n-1),x(0),x(1),x(2),...,x(n),x(0)
!         i.e. explicit cyclic continuity; (n+2) locations required
!
!     vectorization is achieved on cray by doing the transforms in
!     parallel
!
!     *** n.b. n is assumed to be an even number
!
!     definition of transforms:
!     -------------------------
!
!     isign=+1: x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!         where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!
!     isign=-1: a(k)=(1/n)*sum(j=0,...,n-1)(x(j)*cos(2*j*k*pi/n))
!               b(k)=-(1/n)*sum(j=0,...,n-1)(x(j)*sin(2*j*k*pi/n))
!

    integer :: nfax, nx, nh, ink, igo, ibase, jbase
    integer :: i, j, k, L, m, ia, la, ib

      nfax=ifax(1)
      nx=n+1
      nh=n/2
      ink=inc+inc
      if (isign.eq.+1) go to 30

!   if necessary, transfer data to work area
      igo=50
      if (mod(nfax,2).eq.1) goto 40
      ibase=inc+1
      jbase=1
    do L=1,lot
      i=ibase
      j=jbase
!dir$ ivdep
      do m=1,n
        work(j)=a(i)
        i=i+inc
        j=j+1
      enddo
      ibase=ibase+jump
      jbase=jbase+nx
    enddo

      igo=60
      go to 40

!   preprocessing (isign=+1)
!   ------------------------

   30 continue
      call fft99a(a,work,trigs,inc,jump,n,lot)
      igo=60

!   complex transform
!   -----------------

   40 continue
      ia=inc+1
      la=1
      do 80 k=1,nfax
      if (igo.eq.60) go to 60
   50 continue
      call vpassm (a(ia),a(ia+inc),work(1),work(2),trigs, &
                   ink,2,jump,nx,lot,nh,ifax(k+1),la)
      igo=60
      go to 70
   60 continue
      call vpassm (work(1),work(2),a(ia),a(ia+inc),trigs, &
                   2,ink,nx,jump,lot,nh,ifax(k+1),la)
      igo=50
   70 continue
      la=la*ifax(k+1)
   80 continue

    if (isign.eq.-1) go to 130

! if necessary, transfer data from work area

    if (mod(nfax,2).ne.1) then
      ibase=1
      jbase=ia
      do L=1,lot
        i=ibase
        j=jbase
!dir$ ivdep
        do m=1,n
          a(j)=work(i)
          i=i+1
          j=j+inc
        enddo
        ibase=ibase+nx
        jbase=jbase+jump
      enddo
    endif

!   fill in cyclic boundary points
      ia=1
      ib=n*inc+1
!dir$ ivdep
      do L=1,lot
        a(ia)=a(ib)
        a(ib+inc)=a(ia+inc)
        ia=ia+jump
        ib=ib+jump
      enddo
      go to 140

!   postprocessing (isign=-1):
!   --------------------------

  130 continue
      call fft99b(work,a,trigs,inc,jump,n,lot)

  140 continue

    end subroutine fft99

!##########################################################################

    subroutine fft99a (a,work,trigs,inc,jump,n,lot)
    integer, intent(in)    :: inc,jump,n,lot
    real(r8),    intent(in)    :: trigs(:)
    real(r8),    intent(inout) :: a(*),work(*)

!     dimension a(n),work(n),trigs(n)
!
!     subroutine fft99a - preprocessing step for fft99, isign=+1
!     (spectral to gridpoint transform)

    integer :: nh, nx, ink, k, L
    integer :: ia, ib, ja, jb, iabase, ibbase, jabase, jbbase
    real(r8)    :: c, s

      nh=n/2
      nx=n+1
      ink=inc+inc

!   a(0) and a(n/2)
      ia=1
      ib=n*inc+1
      ja=1
      jb=2
!dir$ ivdep
    do L=1,lot
      work(ja)=a(ia)+a(ib)
      work(jb)=a(ia)-a(ib)
      ia=ia+jump
      ib=ib+jump
      ja=ja+nx
      jb=jb+nx
    enddo

!   remaining wavenumbers
      iabase=2*inc+1
      ibbase=(n-2)*inc+1
      jabase=3
      jbbase=n-1

    do k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
!dir$ ivdep
      do L=1,lot
        work(ja)=(a(ia)+a(ib))- &
            (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
        work(jb)=(a(ia)+a(ib))+ &
            (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
        work(ja+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))+ &
            (a(ia+inc)-a(ib+inc))
        work(jb+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))- &
            (a(ia+inc)-a(ib+inc))
        ia=ia+jump
        ib=ib+jump
        ja=ja+nx
        jb=jb+nx
      enddo
      iabase=iabase+ink
      ibbase=ibbase-ink
      jabase=jabase+2
      jbbase=jbbase-2
    enddo

!   wavenumber n/4 (if it exists)
    if (iabase.eq.ibbase) then
      ia=iabase
      ja=jabase
!dir$ ivdep
      do L=1,lot
        work(ja)=2.0*a(ia)
        work(ja+1)=-2.0*a(ia+inc)
        ia=ia+jump
        ja=ja+nx
      enddo
    endif

    end subroutine fft99a

!##########################################################################

    subroutine fft99b (work,a,trigs,inc,jump,n,lot)
    integer, intent(in)    :: inc,jump,n,lot
    real(r8),    intent(in)    :: trigs(:)
    real(r8),    intent(inout) :: a(*),work(*)

!     dimension work(n),a(n),trigs(n)
!
!     subroutine fft99b - postprocessing step for fft99, isign=-1
!     (gridpoint to spectral transform)

    integer :: nh, nx, ink, k, L
    integer :: ia, ib, ja, jb, iabase, ibbase, jabase, jbbase
    real(r8)    :: rscale, c, s

      nh=n/2
      nx=n+1
      ink=inc+inc

!   a(0) and a(n/2)
      rscale=1.0/(1.0 * n)
      ia=1
      ib=2
      ja=1
      jb=n*inc+1
!dir$ ivdep
    do L=1,lot
      a(ja)=rscale*(work(ia)+work(ib))
      a(jb)=rscale*(work(ia)-work(ib))
      a(ja+inc)=0.0
      a(jb+inc)=0.0
      ia=ia+nx
      ib=ib+nx
      ja=ja+jump
      jb=jb+jump
    enddo

!   remaining wavenumbers
      rscale=0.5*rscale
      iabase=3
      ibbase=n-1
      jabase=2*inc+1
      jbbase=(n-2)*inc+1

    do k=3,nh,2
      ia=iabase
      ib=ibbase
      ja=jabase
      jb=jbbase
      c=trigs(n+k)
      s=trigs(n+k+1)
!dir$ ivdep
      do L=1,lot
        a(ja)=rscale*((work(ia)+work(ib)) &
           +(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
        a(jb)=rscale*((work(ia)+work(ib)) &
           -(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
        a(ja+inc)=rscale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) &
            +(work(ib+1)-work(ia+1)))
        a(jb+inc)=rscale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) &
            -(work(ib+1)-work(ia+1)))
        ia=ia+nx
        ib=ib+nx
        ja=ja+jump
        jb=jb+jump
      enddo
      iabase=iabase+2
      ibbase=ibbase-2
      jabase=jabase+ink
      jbbase=jbbase-ink
    enddo

!   wavenumber n/4 (if it exists)
    if (iabase.eq.ibbase) then
      ia=iabase
      ja=jabase
      rscale=2.0*rscale
!dir$ ivdep
      do L=1,lot
        a(ja)=rscale*work(ia)
        a(ja+inc)=-rscale*work(ia+1)
        ia=ia+nx
        ja=ja+jump
      enddo
    endif

    end subroutine fft99b

!##########################################################################

    subroutine fft991(a,work,trigs,ifax,inc,jump,n,lot,isign)
    integer, intent(in)    :: inc,jump,n,lot,isign
    integer, intent(inout) :: ifax(:)
    real(r8),    intent(in)    :: trigs(:)
    real(r8),    intent(inout) :: a(*),work(*)

!     dimension a(n),work(n),trigs(n),ifax(1)
!
!     subroutine "fft991" - multiple real/half-complex periodic
!     fast fourier transform
!
!     same as fft99 except that ordering of data corresponds to
!     that in mrfft2
!
!     procedure used to convert to half-length complex transform
!     is given by cooley, lewis and welch (j. sound vib., vol. 12
!     (1970), 315-337)
!
!     a is the array containing input and output data
!     work is an area of size (n+1)*lot
!     trigs is a previously prepared list of trig function values
!     ifax is a previously prepared list of factors of n/2
!     inc is the increment within each data 'vector'
!         (e.g. inc=1 for consecutively stored data)
!     jump is the increment between the start of each data vector
!     n is the length of the data vectors
!     lot is the number of data vectors
!     isign = +1 for transform from spectral to gridpoint
!           = -1 for transform from gridpoint to spectral
!
!     ordering of coefficients:
!         a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2)
!         where b(0)=b(n/2)=0; (n+2) locations required
!
!     ordering of data:
!         x(0),x(1),x(2),...,x(n-1)
!
!     vectorization is achieved on cray by doing the transforms in
!     parallel
!
!     *** n.b. n is assumed to be an even number
!
!     definition of transforms:
!     -------------------------
!
!     isign=+1: x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
!         where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
!
!     isign=-1: a(k)=(1/n)*sum(j=0,...,n-1)(x(j)*cos(2*j*k*pi/n))
!               b(k)=-(1/n)*sum(j=0,...,n-1)(x(j)*sin(2*j*k*pi/n))
!

    integer :: nfax, nx, nh, ink, igo, ibase, jbase
    integer :: i, j, k, L, m, ia, la, ib

      nfax=ifax(1)
      nx=n+1
      nh=n/2
      ink=inc+inc
      if (isign.eq.+1) go to 30

!     if necessary, transfer data to work area
      igo=50
      if (mod(nfax,2).eq.1) goto 40
      ibase=1
      jbase=1
    do L=1,lot
      i=ibase
      j=jbase
!dir$ ivdep
      do m=1,n
        work(j)=a(i)
        i=i+inc
        j=j+1
      enddo
      ibase=ibase+jump
      jbase=jbase+nx
    enddo
!
      igo=60
      go to 40
!
!   preprocessing (isign=+1)
!   ------------------------
!
   30 continue
      call fft99a(a,work,trigs,inc,jump,n,lot)
      igo=60
!
!   complex transform
!   -----------------
!
   40 continue
      ia=1
      la=1
    do k=1,nfax
      if (igo.eq.60) go to 60
   50 continue
        call vpassm (a(ia),a(ia+inc),work(1),work(2),trigs, &
                     ink,2,jump,nx,lot,nh,ifax(k+1),la)
      igo=60
      go to 70
   60 continue
        call vpassm (work(1),work(2),a(ia),a(ia+inc),trigs, &
                     2,ink,nx,jump,lot,nh,ifax(k+1),la)
      igo=50
   70 continue
      la=la*ifax(k+1)
    enddo

    if (isign.eq.-1) go to 130

! if necessary, transfer data from work area
    if (mod(nfax,2).ne.1) then
      ibase=1
      jbase=1
      do L=1,lot
        i=ibase
        j=jbase
!dir$ ivdep
        do m=1,n
          a(j)=work(i)
          i=i+1
          j=j+inc
        enddo
        ibase=ibase+nx
        jbase=jbase+jump
      enddo
    endif

!   fill in zeros at end
      ib=n*inc+1
!dir$ ivdep
      do L=1,lot
        a(ib)=0.0
        a(ib+inc)=0.0
        ib=ib+jump
      enddo
      go to 140

!     postprocessing (isign=-1):
!     --------------------------

  130 continue
      call fft99b (work,a,trigs,inc,jump,n,lot)

  140 continue

    end subroutine fft991

!##########################################################################

    subroutine set99 (trigs, ifax, n)
    integer, intent(in)  :: n
    integer, intent(out) :: ifax(:)
    real(r8),    intent(out) :: trigs(:)

!     dimension ifax(13),trigs(1)
!
! mode 3 is used for real/half-complex transforms.  it is possible
! to do complex/complex transforms with other values of mode, but
! documentation of the details were not available when this routine
! was written.
!
    integer :: mode = 3
    integer :: i

      call fax (ifax, n, mode)
      i = ifax(1)
      if (ifax(i+1) .gt. 5 .or. n .le. 4) ifax(1) = -99
      if (ifax(1) .le. 0 ) then
        write(6,*) ' set99 -- invalid n'
        stop
      endif
      call fftrig (trigs, n, mode)

    end subroutine set99

!##########################################################################

    subroutine fax (ifax,n,mode)
    integer, intent(out) :: ifax(:)
    integer, intent(in)  :: n, mode

    integer :: nn, k, L, inc, nfax, ii, istop, i, item

      nn=n
      if (iabs(mode).eq.1) go to 10
      if (iabs(mode).eq.8) go to 10
      nn=n/2
      if ((nn+nn).eq.n) go to 10
      ifax(1)=-99
      return
   10 k=1
!     test for factors of 4
   20 if (mod(nn,4).ne.0) go to 30
      k=k+1
      ifax(k)=4
      nn=nn/4
      if (nn.eq.1) go to 80
      go to 20
!     test for extra factor of 2
   30 if (mod(nn,2).ne.0) go to 40
      k=k+1
      ifax(k)=2
      nn=nn/2
      if (nn.eq.1) go to 80
!     test for factors of 3
   40 if (mod(nn,3).ne.0) go to 50
      k=k+1
      ifax(k)=3
      nn=nn/3
      if (nn.eq.1) go to 80
      go to 40
!     now find remaining factors
   50 L=5
      inc=2
!     inc alternately takes on values 2 and 4
   60 if (mod(nn,L).ne.0) go to 70
      k=k+1
      ifax(k)=L
      nn=nn/L
      if (nn.eq.1) go to 80
      go to 60
   70 L=L+inc
      inc=6-inc
      go to 60
   80 ifax(1)=k-1
!     ifax(1) contains number of factors
      nfax=ifax(1)
!     sort factors into ascending order
      if (nfax.eq.1) go to 110
      do 100 ii=2,nfax
      istop=nfax+2-ii
      do 90 i=2,istop
      if (ifax(i+1).ge.ifax(i)) go to 90
      item=ifax(i)
      ifax(i)=ifax(i+1)
      ifax(i+1)=item
   90 continue
  100 continue
  110 continue

    end subroutine fax

!##########################################################################

    subroutine fftrig (trigs,n,mode)
    real(r8),    intent(out) :: trigs(:)
    integer, intent(in)  :: n, mode

    real(r8)    :: del, angle
    integer :: imode, nn, nh, i, L, la

      imode=iabs(mode)
      nn=n
      if (imode.gt.1.and.imode.lt.6) nn=n/2
      del=(pi+pi)/(1.0 * nn)
      L=nn+nn
      do i=1,L,2
        angle=0.5*(i-1.0)*del
        trigs(i)=cos(angle)
        trigs(i+1)=sin(angle)
      enddo
      if (imode.eq.1) return
      if (imode.eq.8) return

      del=0.5*del
      nh=(nn+1)/2
      L=nh+nh
      la=nn+nn
      do i=1,L,2
        angle=0.5*(i-1.0)*del
        trigs(la+i)=cos(angle)
        trigs(la+i+1)=sin(angle)
      enddo
      if (imode.le.3) return

      del=0.5*del
      la=la+nn
    if (mode.ne.5) then
      do i=2,nn
        angle=(i-1.0)*del
        trigs(la+i)=2.0*sin(angle)
      enddo
      return
    endif

      del=0.5*del
      do i=2,n
        angle=(i-1.0)*del
        trigs(la+i)=sin(angle)
      enddo

    end subroutine fftrig

!##########################################################################

    subroutine vpassm (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la)
    integer, intent(in)  :: inc1, inc2, inc3, inc4, lot, n, ifac, la
    real(r8),    intent(in)  :: a(*),b(*),trigs(*)
    real(r8),    intent(out) :: c(*),d(*)
!
!     subroutine "vpassm" - multiple version of "vpassa"
!     performs one pass through data
!     as part of multiple complex fft routine
!     a is first real input vector
!     b is first imaginary input vector
!     c is first real output vector
!     d is first imaginary output vector
!     trigs is precalculated table of sines " cosines
!     inc1 is addressing increment for a and b
!     inc2 is addressing increment for c and d
!     inc3 is addressing increment between a"s & b"s
!     inc4 is addressing increment between c"s & d"s
!     lot is the number of vectors
!     n is length of vectors
!     ifac is current factor of n
!     la is product of previous factors
!

    real(r8) :: sin36=0.587785252292473
    real(r8) :: cos36=0.809016994374947
    real(r8) :: sin72=0.951056516295154
    real(r8) :: cos72=0.309016994374947
    real(r8) :: sin60=0.866025403784437

    integer :: i, j, k, L, m, iink, jink, jump, ibase, jbase, igo, ijk, la1
    integer :: ia, ja, ib, jb, kb, ic, jc, kc, id, jd, kd, ie, je, ke
    real(r8)    :: c1, s1, c2, s2, c3, s3, c4, s4
      m=n/ifac
      iink=m*inc1
      jink=la*inc2
      jump=(ifac-1)*jink
      ibase=0
      jbase=0
      igo=ifac-1
      if (igo.gt.4) return
!del  go to (10,50,90,130),igo

  select case (igo)

!   coding for factor 2

    case (1)
   10 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      do 20 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 15 ijk=1,lot
!!!if(ib + 1 > size(a)) goto 15
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=a(ia+i)-a(ib+i)
      d(jb+j)=b(ia+i)-b(ib+i)
      i=i+inc3
      j=j+inc4
   15 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   20 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 40 k=la1,m,la
      kb=k+k-2
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      do 30 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 25 ijk=1,lot
      c(ja+j)=a(ia+i)+a(ib+i)
      d(ja+j)=b(ia+i)+b(ib+i)
      c(jb+j)=c1*(a(ia+i)-a(ib+i))-s1*(b(ia+i)-b(ib+i))
      d(jb+j)=s1*(a(ia+i)-a(ib+i))+c1*(b(ia+i)-b(ib+i))
      i=i+inc3
      j=j+inc4
   25 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   30 continue
      jbase=jbase+jump
   40 continue
!     return

!   coding for factor 3

    case (2)
   50 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      do 60 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 55 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))
      c(jc+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))
      d(jb+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))
      d(jc+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))
      i=i+inc3
      j=j+inc4
   55 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   60 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 80 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      do 70 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 65 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
      c(jb+j)=                                                           &
          c1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) &
         -s1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      d(jb+j)=                                                           &
          s1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) &
         +c1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
      c(jc+j)=                                                           &
          c2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) &
         -s2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      d(jc+j)=                                                           &
          s2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) &
         +c2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
      i=i+inc3
      j=j+inc4
   65 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
   70 continue
      jbase=jbase+jump
   80 continue
!     return

!   coding for factor 4

    case (3)
   90 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      do 100 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 95 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))
      c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))
      c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))
      d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))
      d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))
      i=i+inc3
      j=j+inc4
   95 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  100 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 120 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      do 110 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 105 ijk=1,lot
      c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
      d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
      c(jc+j)=                                     &
          c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) &
         -s2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      d(jc+j)=                                     &
          s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) &
         +c2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
      c(jb+j)=                                     &
          c1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) &
         -s1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      d(jb+j)=                                     &
          s1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) &
         +c1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
      c(jd+j)=                                     &
          c3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) &
         -s3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      d(jd+j)=                                     &
          s3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) &
         +c3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  105 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  110 continue
      jbase=jbase+jump
  120 continue
!     return

!   coding for factor 5

    case (4)
  130 ia=1
      ja=1
      ib=ia+iink
      jb=ja+jink
      ic=ib+iink
      jc=jb+jink
      id=ic+iink
      jd=jc+jink
      ie=id+iink
      je=jd+jink
      do 140 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 135 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
        -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
        +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
      d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
        +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
        -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
      c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
        -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
        +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
      d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
        +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
        -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
      i=i+inc3
      j=j+inc4
  135 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  140 continue
      if (la.eq.m) return
      la1=la+1
      jbase=jbase+jump
      do 160 k=la1,m,la
      kb=k+k-2
      kc=kb+kb
      kd=kc+kb
      ke=kd+kb
      c1=trigs(kb+1)
      s1=trigs(kb+2)
      c2=trigs(kc+1)
      s2=trigs(kc+2)
      c3=trigs(kd+1)
      s3=trigs(kd+2)
      c4=trigs(ke+1)
      s4=trigs(ke+2)
      do 150 L=1,la
      i=ibase
      j=jbase
!dir$ ivdep
      do 145 ijk=1,lot
      c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
      d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
      c(jb+j)=                                                          &
          c1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         -s1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(jb+j)=                                                          &
          s1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         +c1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(je+j)=                                                          &
          c4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         -s4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      d(je+j)=                                                          &
          s4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) &
            +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))         &
         +c4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) &
            -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
      c(jc+j)=                                                          &
          c2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         -s2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jc+j)=                                                          &
          s2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         +c2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      c(jd+j)=                                                          &
          c3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         -s3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      d(jd+j)=                                                          &
          s3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) &
            +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))         &
         +c3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) &
            -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
      i=i+inc3
      j=j+inc4
  145 continue
      ibase=ibase+inc1
      jbase=jbase+inc2
  150 continue
      jbase=jbase+jump
  160 continue

  end select

    end subroutine vpassm

!##########################################################################

end module fft99_mod


MODULE model_tools

CONTAINS

!STEVE: borrowed from mom4p1, heavily edited
!#######################################################################
! <SUBROUTINE NAME="calc_mixed_layer_depth">
!
! <DESCRIPTION>
!
! Calculate the mixed layer depth (m), which is defined as the depth ( > 0 )
! where the buoyancy difference with respect to the surface level is
! equal to buoyancy_crit (m/s2).
!
! Note that the mixed layer depth is taken with respect to the ocean surface
! at z=eta_t, so the mixed layer depth is always positive. That is, the mld
! is here defined as a thickness of water.
!
! </DESCRIPTION>
!
subroutine calc_mixed_layer_depth(Thickness, salinity, theta, rho, pressure, hmxl, smooth_mld_input)

  type(ocean_thickness_type),   intent(in)  :: Thickness
  real, dimension(isd:,jsd:,:), intent(in)  :: salinity
  real, dimension(isd:,jsd:,:), intent(in)  :: theta
  real, dimension(isd:,jsd:,:), intent(in)  :: rho
  real, dimension(isd:,jsd:,:), intent(in)  :: pressure
  real, dimension(isd:,jsd:),   intent(out) :: hmxl
  logical, optional,            intent(in)  :: smooth_mld_input

  real, parameter :: epsln=1.0e-20  ! for divisions
  integer         :: i, j, k, km1, kb
  logical         :: smooth_mld_routine

  if (.not.module_is_initialized) then
    call mpp_error(FATAL, &
    '==>Error from ocean_tracer_diag_mod (calc_mixed_layer_depth): module needs initialization ')
  endif

   if (present(smooth_mld_input)) then
    smooth_mld_routine = smooth_mld_input
  else
    smooth_mld_routine = smooth_mld
  endif

  hmxl(:,:)   = 0.0
  wrk1(:,:,:) = 0.0
  wrk2(:,:,:) = 0.0

  wrk1(:,:,:) = density_delta_sfc( rho(:,:,:), salinity(:,:,:), theta(:,:,:), pressure(:,:,:))
  do k=2,nk
     do j=jsc,jec
        do i=isc,iec
           wrk2(i,j,k) = -grav*Grd%tmask(i,j,k)*wrk1(i,j,k-1)/(epsln+rho(i,j,k))
        enddo
     enddo
  enddo

  do j=jsc,jec
     do i=isc,iec
        kb=Grd%kmt(i,j)
        if(kb==0) then
            hmxl(i,j) = 0.0
        else
            hmxl(i,j) = Thickness%depth_zwt(i,j,kb)
        endif
     enddo
  enddo

  do k=2,nk
     km1 = k-1
     do j=jsc,jec
        do i=isc,iec
        kb=Grd%kmt(i,j)
           if (kb == 0) then
               hmxl(i,j) = 0.0
           else
               if ( wrk2(i,j,k) >= buoyancy_crit .and. hmxl(i,j)==Thickness%depth_zwt(i,j,kb)) then
                   hmxl(i,j) = Thickness%depth_zt(i,j,km1)                                &
                             - (Thickness%depth_zt(i,j,km1) - Thickness%depth_zt(i,j,k))  &
                             * (buoyancy_crit-wrk2(i,j,km1))                              &
                             / (wrk2(i,j,k) - wrk2(i,j,km1) + epsln)
               endif
               hmxl(i,j) = hmxl(i,j) * Grd%tmask(i,j,1)
           endif
        enddo
     enddo
  enddo

 ! smooth mld
  if(smooth_mld_routine) then
      call mpp_update_domains(hmxl(:,:), Dom%domain2d)
      hmxl(:,:) = S2D(hmxl(:,:))
  endif

end subroutine calc_mixed_layer_depth
! </SUBROUTINE>  NAME="calc_mixed_layer_depth"

END MODULE model_tools


SUBROUTINE PoissonSolver( Model,Solver,dt,TransientSimulation )
!------------------------------------------------------------------------------
!******************************************************************************
!
!  Solve the Poisson equation!
!
!  ARGUMENTS:
!
!  TYPE(Model_t) :: Model,
!     INPUT: All model information (mesh, materials, BCs, etc...)
!
!  TYPE(Solver_t) :: Solver
!     INPUT: Linear & nonlinear equation solver options
!
!  REAL(KIND=dp) :: dt,
!     INPUT: Timestep size for time dependent simulations
!
!  LOGICAL :: TransientSimulation
!     INPUT: Steady state or transient simulation
!
!******************************************************************************
  USE DefUtils

  IMPLICIT NONE
!------------------------------------------------------------------------------
  TYPE(Solver_t) :: Solver
  TYPE(Model_t) :: Model

  REAL(KIND=dp) :: dt
  LOGICAL :: TransientSimulation
!------------------------------------------------------------------------------
! Local variables
!------------------------------------------------------------------------------
  TYPE(Element_t),POINTER :: Element

  LOGICAL :: AllocationsDone = .FALSE., Found

  INTEGER :: n, t, istat, active
  REAL(KIND=dp) :: Norm

  TYPE(ValueList_t), POINTER :: BodyForce
  TYPE(Mesh_t), POINTER :: Mesh
  REAL(KIND=dp), ALLOCATABLE :: STIFF(:,:), LOAD(:), FORCE(:)

  SAVE STIFF, LOAD, FORCE, AllocationsDone
!------------------------------------------------------------------------------

  Mesh => GetMesh()

  !Allocate some permanent storage, this is done first time only:
  !--------------------------------------------------------------
  IF ( .NOT. AllocationsDone ) THEN
     N = Mesh % MaxElementNodes ! just big enough for elemental arrays
     ALLOCATE( FORCE(N), LOAD(N), STIFF(N,N), STAT=istat )
     IF ( istat /= 0 ) THEN
        CALL Fatal( 'PoissonSolve', 'Memory allocation error.' )
     END IF
     AllocationsDone = .TRUE.
  END IF

   !Initialize the system and do the assembly:
   !------------------------------------------
   CALL DefaultInitialize()

   active = GetNOFActive()
   DO t=1,active
      Element => GetActiveElement(t)
      n = GetElementNOFNodes()

      LOAD = 0.0d0
      BodyForce => GetBodyForce()
      IF ( ASSOCIATED(BodyForce) ) &
         Load(1:n) = GetReal( BodyForce, 'Source', Found )

      !Get element local matrix and rhs vector:
      !----------------------------------------
      CALL LocalMatrix(  STIFF, FORCE, LOAD, Element, n )

      !Update global matrix and rhs vector from local matrix & vector:
      !---------------------------------------------------------------
      CALL DefaultUpdateEquations( STIFF, FORCE )
   END DO

   CALL DefaultFinishAssembly()
   CALL DefaultDirichletBCs()
   Norm = DefaultSolve()

CONTAINS

!------------------------------------------------------------------------------
  SUBROUTINE LocalMatrix(  STIFF, FORCE, LOAD, Element, n )
!------------------------------------------------------------------------------
    REAL(KIND=dp) :: STIFF(:,:), FORCE(:), LOAD(:)
    INTEGER :: n
    TYPE(Element_t), POINTER :: Element
!------------------------------------------------------------------------------
    REAL(KIND=dp) :: Basis(n),dBasisdx(n,3),DetJ,LoadAtIP
    LOGICAL :: Stat
    INTEGER :: t
    TYPE(GaussIntegrationPoints_t) :: IP

    TYPE(Nodes_t) :: Nodes
    SAVE Nodes
!------------------------------------------------------------------------------
    CALL GetElementNodes( Nodes )
    STIFF = 0.0d0
    FORCE = 0.0d0

    !Numerical integration:
    !----------------------
    IP = GaussPoints( Element )
    DO t=1,IP % n
       ! Basis function values & derivatives at the integration point:
       !--------------------------------------------------------------
       stat = ElementInfo( Element, Nodes, IP % U(t), IP % V(t), &
               IP % W(t),  detJ, Basis, dBasisdx )

       ! The source term at the integration point:
       !------------------------------------------
       LoadAtIP = SUM( Basis(1:n) * LOAD(1:n) )

       ! Finally, the elemental matrix & vector:
       !----------------------------------------
       STIFF(1:n,1:n) = STIFF(1:n,1:n) + IP % s(t) * DetJ * &
            MATMUL( dBasisdx, TRANSPOSE( dBasisdx ) )
       FORCE(1:n) = FORCE(1:n) + IP % s(t) * DetJ * LoadAtIP * Basis(1:n)
    END DO
!------------------------------------------------------------------------------
  END SUBROUTINE LocalMatrix
!------------------------------------------------------------------------------
END SUBROUTINE PoissonSolver
!------------------------------------------------------------------------------


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine str2mat(str,ckl,vj,cauchy)
!
!     converts the stress in spatial coordinates into material coordinates
!     or the strain in material coordinates into spatial coordinates.
!
!     INPUT:
!
!     str(6):     Cauchy stress, Kirchhoff stress or Lagrange strain
!                 component order: 11,22,33,12,13,23
!     ckl(3,3):   the inverse deformation gradient
!     vj:         Jakobian determinant
!     cauchy:     integer variable
!                 if 1: str contains the Cauchy stress
!                 if 0: str contains the Kirchhoff stress or
!                           Lagrange strain
!
!     OUTPUT:
!
!     str(6):     Piola-Kirchhoff stress of the second kind (PK2) or
!                 Euler strain
!
      implicit none
!
      integer cauchy
!
      integer i,m1,m2
!
      real*8 str(6),s(6),ckl(3,3),vj
!
      do i=1,6
         if(i.eq.1) then
            m1=1
            m2=1
         elseif(i.eq.2) then
            m1=2
            m2=2
         elseif(i.eq.3) then
            m1=3
            m2=3
         elseif(i.eq.4) then
            m1=2
            m2=1
         elseif(i.eq.5) then
            m1=3
            m2=1
         else
            m1=3
            m2=2
         endif
!
         s(i)=(str(1)*ckl(m1,1)*ckl(m2,1)+
     &        str(2)*ckl(m1,2)*ckl(m2,2)+
     &        str(3)*ckl(m1,3)*ckl(m2,3)+
     &        str(4)*(ckl(m1,1)*ckl(m2,2)+ckl(m1,2)*ckl(m2,1))+
     &        str(5)*(ckl(m1,1)*ckl(m2,3)+ckl(m1,3)*ckl(m2,1))+
     &        str(6)*(ckl(m1,2)*ckl(m2,3)+ckl(m1,3)*ckl(m2,2)))
!
      enddo
!
      if(cauchy.eq.1) then
         do i=1,6
            str(i)=s(i)*vj
         enddo
      else
         do i=1,6
            str(i)=s(i)
         enddo
      endif
!
      return
      end


C FUNCTION FCHISQ.F
C
C SOURCE
C   BEVINGTON, PAGE 194.
C
C PURPOSE
C   EVALUATE REDUCED CHI SQUARE FOR FIT OF DATA
C     FCHISQ = SUM ((Y-YFIT)**2 / SIGMA**2) / NFREE
C
C USAGE
C   RESULT = FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT)
C
C DESCRIPTION OF PARAMETERS
C   Y	   - ARRAY OF DATA POINTS
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR DATA POINTS
C   NPTS   - NUMBER OF DATA POINTS
C   NFREE  - NUMBER OF DEGREES OF FREEDOM
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C	      0 (NO WEIGHTING) WEIGHT(I) = 1.
C	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   YFIT   - ARRAY OF CALCULATED VALUES OF Y
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   NONE
C
	FUNCTION FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
	DOUBLE PRECISION CHISQ,WEIGHT
	DIMENSION Y(1),SIGMAY(1),YFIT(1)
11	CHISQ=0.
12	IF (NFREE) 13,13,20
13	FCHISQ=0.
	GOTO 40
C
C ACCUMULATE CHI SQUARE
C
20	DO 30 I=1,NPTS
21	IF (MODE) 22,27,29
22	IF (Y(I)) 25,27,23
23	WEIGHT=1./Y(I)
	GOTO 30
25	WEIGHT=1./(-Y(I))
	GOTO 30
27	WEIGHT=1.
	GOTO 30
29	WEIGHT=1./SIGMAY(I)**2
30	CHISQ=CHISQ+WEIGHT*(Y(I)-YFIT(I))**2
C
C	DIVIDE BY NUMBER OF DEGREES OF FREEDOM
C
31	FREE=NFREE
32	FCHISQ=CHISQ/FREE
40	RETURN
	END


      PROGRAM xmppi
C     driver for mp routines
      INTEGER n
3     write(*,*) 'INPUT N'
      read(*,*,END=999) n
      call mpinit
      call mpsqr2(n)
      call mppi(n)
      goto 3
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END
      SUBROUTINE mpsqr2(n)
      INTEGER IAOFF,NMAX
      PARAMETER (IAOFF=48,NMAX=8192)
      INTEGER j,n,m
      CHARACTER*1 x(NMAX),y(NMAX),t(NMAX),s(3*NMAX),q(NMAX),r(NMAX)
      t(1)=char(2)
      do 11 j=2,n
        t(j)=char(0)
11    continue
      call mpsqrt(x,x,t,n,n)
      call mpmov(y,x,n)
      write(*,*) 'SQRT(2)='
      s(1)=char(ichar(y(1))+IAOFF)
      s(2)='.'
C     caution: next step is N**2! omit it for large N
      call mp2dfr(y(2),s(3),n-1,m)
      write(*,'(1x,64a1)') (s(j),j=1,m+2)
      write(*,*) 'Result rounded to 1 less base-256 place:'
C     use s as scratch space
      call mpsad(s,x,n,128)
      call mpmov(y,s(2),n-1)
      s(1)=char(ichar(y(1))+IAOFF)
      s(2)='.'
C     caution: next step is N**2! omit it for large N
      call mp2dfr(y(2),s(3),n-2,m)
      write(*,'(1x,64a1)') (s(j),j=1,m+2)
      write(*,*) '2-SQRT(2)='
C     calculate this the hard way to exercise the mpdiv function
      call mpdiv(q,r,t,x,n,n)
      s(1)=char(ichar(r(1))+IAOFF)
      s(2)='.'
C     caution: next step is N**2! omit it for large N
      call mp2dfr(r(2),s(3),n-1,m)
      write(*,'(1x,64a1)') (s(j),j=1,m+2)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xmppi.for


*----------------------------------------------------------------------*
      integer(8) function int8_pack(int_exp,nexp,ibase)
*----------------------------------------------------------------------*
*     pack a list of small integers into one integer using base (ibase)
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     nexp, int_exp(nexp), ibase
      integer(8) ::
     &     ib8, int, ibs, n, iexp

      int = 0
      ibs = 1
      ib8 = ibase
      do iexp = 1, nexp, 4
        n = int_exp(iexp)
        int = int + n*ibs
        ibs = ibs*ib8
        n = int_exp(iexp+1)
        int = int + n*ibs
        ibs = ibs*ib8
        n = int_exp(iexp+2)
        int = int + n*ibs
        ibs = ibs*ib8
        n = int_exp(iexp+3)
        int = int + n*ibs
        ibs = ibs*ib8
      end do
      do iexp = nexp - mod(nexp,4) + 1, nexp
        n = int_exp(iexp)
        int = int + n*ibs
        ibs = ibs*ib8
      end do

      int8_pack = int

      return

c 100  write(lulog,*) 'intlist not suited for packing:'
c      write(lulog,*) ' list = ',int_exp(1:nexp)
c      write(lulog,*) ' base = ',ibase
c      call quit(1,'int8_pack','intlist not suited for packing')

      end


use MeshClass
use FEMDomainClass
implicit none

type(FEMDomain_) :: cube
type(IO_) :: f
integer(int32),allocatable :: GroupID(:,:)
real(real64),allocatable :: Element_Group_ID(:)
integer(int32) :: i,j

call cube%create("Cube3D",x_num=200,y_num=200,z_num=100)
call cube%resize(x=200.0d0)
call cube%resize(y=200.0d0)
call cube%resize(z=100.0d0)

! Binary-Tree Search for 8-node isoparametric elements
GroupID = cube%mesh%BinaryTreeSearch(old_GroupID=GroupID,min_elem_num=10000)
Element_Group_ID = int(zeros(cube%ne() ) )
do i=1,size(GroupID,1)
    do j=1,size(GroupID,2)
        Element_Group_ID(GroupID(i,j)) = dble(i)
    enddo
enddo

! Number of Group, Number of Elements in a group
print*, size(GroupID,1),size(GroupID,2)

! visualize
call cube%vtk("groups",scalar=Element_Group_ID)

! export
!call f%open("BinaryTree.txt")
!call f%write( GroupID)
!call f%close()

end