Makefile 0000644 0001750 0001750 00000004536 13051021044 012424 0 ustar slaizet slaizet #=======================================================================
# Makefile for Imcompact3D
#=======================================================================
# Choose pre-processing options
# -DSHM - enable shared-memory implementation
# -DDOUBLE_PREC - use double-precision
OPTIONS = -DDOUBLE_PREC
# Choose an FFT engine, available options are:
# fftw3 - FFTW version 3.x
# generic - A general FFT algorithm (no 3rd-party library needed)
FFT= generic
# Paths to FFTW 3
FFTW3_PATH= # full path of FFTW installation if using fftw3 engine above
FFTW3_INCLUDE = -I$(FFTW3_PATH)/include
FFTW3_LIB = -L$(FFTW3_PATH)/lib -lfftw3 -lfftw3f
# Specify Fortran and C compiler names and flags here
# Normally, use MPI wrappers rather than compilers themselves
# Supply a Fortran pre-processing flag together with optimisation level flags
# Some examples are given below:
#FC =
#OPTFC =
#CC =
#CFLAGS =
# PGI
#FC = ftn
#OPTFC = -fast -O3 -Mpreprocess
#CC = cc
#CFLAGS = -O3
# PathScale
#FC = ftn
#OPTFC = -Ofast -cpp
#CC = cc
#CFLAGS = -O3
# GNU
FC = mpif90
OPTFC = -O3 -funroll-loops -ftree-vectorize -fcray-pointer -cpp
CC = mpicc
CFLAGS = -O3
# Cray
#FC = ftn
#OPTFC = -e Fm
#CC = cc
#CFLAGS =
#-----------------------------------------------------------------------
# Normally no need to change anything below
# include PATH
ifeq ($(FFT),generic)
INC=
else ifeq ($(FFT),fftw3)
INC=$(FFTW3_INCLUDE)
endif
# library path
ifeq ($(FFT),generic)
LIBFFT=
else ifeq ($(FFT),fftw3)
LIBFFT=$(FFTW3_LIB)
endif
# List of source files
SRC = decomp_2d.f90 glassman.f90 fft_$(FFT).f90 module_param.f90 io.f90 variables.f90 poisson.f90 schemes.f90 convdiff.f90 incompact3d.f90 navier.f90 filter.f90 derive.f90 parameters.f90 tools.f90 visu.f90 test_min_max.f90
#-----------------------------------------------------------------------
# Normally no need to change anything below
ifneq (,$(findstring DSHM,$(OPTIONS)))
SRC := FreeIPC.f90 $(SRC)
OBJ = $(SRC:.f90=.o) alloc_shm.o FreeIPC_c.o
else
OBJ = $(SRC:.f90=.o)
endif
all: incompact3d
alloc_shm.o: alloc_shm.c
$(CC) $(CFLAGS) -c $<
FreeIPC_c.o: FreeIPC_c.c
$(CC) $(CFLAGS) -c $<
incompact3d : $(OBJ)
$(FC) -O3 -o $@ $(OBJ) $(LIBFFT)
%.o : %.f90
$(FC) $(OPTFC) $(OPTIONS) $(INC) -c $<
.PHONY: clean
clean:
rm -f *.o *.mod incompact3d
.PHONY: realclean
realclean: clean
rm -f *~ \#*\#
incompact3d.prm 0000644 0001750 0001750 00000003144 13051021044 013702 0 ustar slaizet slaizet #
# INCOMPACT 3D Flow parameters
#
6.28318530718 #xlx # Lx (Size of the box in x-direction)
6.28318530718 #yly # Ly (Size of the box in y-direction)
6.28318530718 #zlz # Lz (Size of the box in z-direction)
1600. #re # Reynolds number
1. #sc # Schmidt number (if passive scalar)
1. #u1 # u1 (max velocity) (for inflow condition)
0. #u2 # u2 (min velocity) (for inflow condition)
0.0 #noise# Turbulence intensity (1=100%) !! Initial condition
0.0 #noise1# Turbulence intensity (1=100%) !! Inflow condition
0.001 #dt # Time step
#
# INCOMPACT3D Flow configuration
#
0 #nclx # nclx (BC)
0 #ncly # ncly (BC)
0 #nclz # nclz (BC)
6 #itype # Type of flow
1 #iin # Inflow condition (1: classic, 2: turbinit)
1 #ifirst # First iteration
20000 #ilast # Last iteration
2 #nscheme# Temporal scheme (1:AB2, 2: RK3, 3:RK4, 4:AB3)
0 #istret # y mesh refinement (0:no, 1:center, 2:both sides, 3:bottom)
0.3 #beta # Refinement parameter (beta)
1 #iskew # (0:urotu, 1:skew, for the convective terms)
0 #iscalar# (0: no scalar, 1:scalar)
#
# INCOMPACT 3D File parameters
#
0 #ilit # Read initial flow field ?
5000 #isave # Frequency for writing backup file
1000 #imodulo # Frequency for visualization for VISU_INSTA
#
# INCOMPACT 3D Body old school
#
0 #ivirt# IBM? (1: old school, 2: Lagrangian Poly)
5. #cex # X-centre position of the solid body
6. #cey # Y-centre position of the solid body
0. #cez # Z-centre position of the solid body
0.5 #re # Radius of the solid body
#
alloc.f90 0000644 0001750 0001750 00000015743 13051023554 012410 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Utility routine to help allocate 3D arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! X-pencil real arrays
subroutine alloc_x_real(var, opt_decomp, opt_global)
implicit none
real(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%xst(1):decomp%xen(1), &
decomp%xst(2):decomp%xen(2), decomp%xst(3):decomp%xen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_x_real
! X-pencil complex arrays
subroutine alloc_x_complex(var, opt_decomp, opt_global)
implicit none
complex(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%xst(1):decomp%xen(1), &
decomp%xst(2):decomp%xen(2), decomp%xst(3):decomp%xen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_x_complex
! Y-pencil real arrays
subroutine alloc_y_real(var, opt_decomp, opt_global)
implicit none
real(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%yst(1):decomp%yen(1), &
decomp%yst(2):decomp%yen(2), decomp%yst(3):decomp%yen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%ysz(1),decomp%ysz(2),decomp%ysz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_y_real
! Y-pencil complex arrays
subroutine alloc_y_complex(var, opt_decomp, opt_global)
implicit none
complex(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%yst(1):decomp%yen(1), &
decomp%yst(2):decomp%yen(2), decomp%yst(3):decomp%yen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%ysz(1),decomp%ysz(2),decomp%ysz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_y_complex
! Z-pencil real arrays
subroutine alloc_z_real(var, opt_decomp, opt_global)
implicit none
real(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%zst(1):decomp%zen(1), &
decomp%zst(2):decomp%zen(2), decomp%zst(3):decomp%zen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_z_real
! Z-pencil complex arrays
subroutine alloc_z_complex(var, opt_decomp, opt_global)
implicit none
complex(mytype), allocatable, dimension(:,:,:) :: var
TYPE(DECOMP_INFO), intent(IN), optional :: opt_decomp
logical, intent(IN), optional :: opt_global
TYPE(DECOMP_INFO) :: decomp
logical :: global
integer :: alloc_stat, errorcode
if (present(opt_decomp)) then
decomp = opt_decomp
else
decomp = decomp_main
end if
if (present(opt_global)) then
global = opt_global
else
global = .false.
end if
if (global) then
allocate(var(decomp%zst(1):decomp%zen(1), &
decomp%zst(2):decomp%zen(2), decomp%zst(3):decomp%zen(3)), &
stat=alloc_stat)
else
allocate(var(decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)), &
stat=alloc_stat)
end if
if (alloc_stat /= 0) then
errorcode = 8
call decomp_2d_abort(errorcode, &
'Memory allocation failed when creating new arrays')
end if
return
end subroutine alloc_z_complex
convdiff.f90 0000644 0001750 0001750 00000040761 13051023554 013112 0 ustar slaizet slaizet !################################################################################
!This file is part of Incompact3d.
!
!Incompact3d
!Copyright (c) 2012 Eric Lamballais and Sylvain Laizet
!eric.lamballais@univ-poitiers.fr / sylvain.laizet@gmail.com
!
! Incompact3d 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.
!
! Incompact3d 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 the code. If not, see .
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
! We kindly request that you cite Incompact3d in your publications and
! presentations. The following citations are suggested:
!
! 1-Laizet S. & Lamballais E., 2009, High-order compact schemes for
! incompressible flows: a simple and efficient method with the quasi-spectral
! accuracy, J. Comp. Phys., vol 228 (15), pp 5989-6015
!
! 2-Laizet S. & Li N., 2011, Incompact3d: a powerful tool to tackle turbulence
! problems with up to 0(10^5) computational cores, Int. J. of Numerical
! Methods in Fluids, vol 67 (11), pp 1735-1757
!################################################################################
!********************************************************************
!
subroutine convdiff(ux1,uy1,uz1,ta1,tb1,tc1,td1,te1,tf1,tg1,th1,ti1,di1,&
ux2,uy2,uz2,ta2,tb2,tc2,td2,te2,tf2,tg2,th2,ti2,tj2,di2,&
ux3,uy3,uz3,ta3,tb3,tc3,td3,te3,tf3,tg3,th3,ti3,di3)
!
!********************************************************************
USE param
USE variables
USE decomp_2d
USE MPI
implicit none
real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ux1,uy1,uz1
real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ta1,tb1,tc1,td1,te1,tf1,tg1,th1,ti1,di1
real(mytype),dimension(ysize(1),ysize(2),ysize(3)) :: ux2,uy2,uz2
real(mytype),dimension(ysize(1),ysize(2),ysize(3)) :: ta2,tb2,tc2,td2,te2,tf2,tg2,th2,ti2,tj2,di2
real(mytype),dimension(zsize(1),zsize(2),zsize(3)) :: ux3,uy3,uz3
real(mytype),dimension(zsize(1),zsize(2),zsize(3)) :: ta3,tb3,tc3,td3,te3,tf3,tg3,th3,ti3,di3
real(mytype) :: ta1min, ta1min1, ta1max, ta1max1
real(mytype) :: tb1min, tb1min1, tb1max, tb1max1
real(mytype) :: tc1min, tc1min1, tc1max, tc1max1
integer :: ijk,nvect1,nvect2,nvect3,i,j,k
integer :: code
real(mytype) :: x,y,z
nvect1=xsize(1)*xsize(2)*xsize(3)
nvect2=ysize(1)*ysize(2)*ysize(3)
nvect3=zsize(1)*zsize(2)*zsize(3)
!!! CM call test_min_max('ux1 ','In convdiff ',ux1,size(ux1))
!!! CM call test_min_max('uy1 ','In convdiff ',uy1,size(uy1))
!!! CM call test_min_max('uz1 ','In convdiff ',uz1,size(uz1))
if (iskew==0) then !UROTU!
!WORK X-PENCILS
call derx (ta1,uy1,di1,sx,ffxp,fsxp,fwxp,xsize(1),xsize(2),xsize(3),1)
call derx (tb1,uz1,di1,sx,ffxp,fsxp,fwxp,xsize(1),xsize(2),xsize(3),1)
call transpose_x_to_y(ux1,ux2)
call transpose_x_to_y(uy1,uy2)
call transpose_x_to_y(uz1,uz2)
call transpose_x_to_y(ta1,ta2)
call transpose_x_to_y(tb1,tb2)
!WORK Y-PENCILS
call dery (tc2,ux2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
call dery (td2,uz2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
call transpose_y_to_z(ux2,ux3)
call transpose_y_to_z(uy2,uy3)
call transpose_y_to_z(uz2,uz3)
call transpose_y_to_z(ta2,ta3)
call transpose_y_to_z(tb2,tb3)
call transpose_y_to_z(tc2,tc3)
call transpose_y_to_z(td2,td3)
!WORK Z-PENCILS
call derz (te3,ux3,di3,sz,ffzp,fszp,fwzp,zsize(1),zsize(2),zsize(3),1)
call derz (tf3,uy3,di3,sz,ffzp,fszp,fwzp,zsize(1),zsize(2),zsize(3),1)
do ijk=1,nvect3
ta3(ijk,1,1)=uz3(ijk,1,1)*(te3(ijk,1,1)-tb3(ijk,1,1))-&
uy3(ijk,1,1)*(ta3(ijk,1,1)-tc3(ijk,1,1))
tb3(ijk,1,1)=ux3(ijk,1,1)*(ta3(ijk,1,1)-tc3(ijk,1,1))-&
uz3(ijk,1,1)*(td3(ijk,1,1)-tf3(ijk,1,1))
tc3(ijk,1,1)=uy3(ijk,1,1)*(td3(ijk,1,1)-tf3(ijk,1,1))-&
ux3(ijk,1,1)*(te3(ijk,1,1)-tb3(ijk,1,1))
enddo
else !SKEW!
!WORK X-PENCILS
do ijk=1,nvect1
ta1(ijk,1,1)=ux1(ijk,1,1)*ux1(ijk,1,1)
tb1(ijk,1,1)=ux1(ijk,1,1)*uy1(ijk,1,1)
tc1(ijk,1,1)=ux1(ijk,1,1)*uz1(ijk,1,1)
enddo
call derx (td1,ta1,di1,sx,ffxp,fsxp,fwxp,xsize(1),xsize(2),xsize(3),1)
call derx (te1,tb1,di1,sx,ffx,fsx,fwx,xsize(1),xsize(2),xsize(3),0)
call derx (tf1,tc1,di1,sx,ffx,fsx,fwx,xsize(1),xsize(2),xsize(3),0)
call derx (ta1,ux1,di1,sx,ffx,fsx,fwx,xsize(1),xsize(2),xsize(3),0)
call derx (tb1,uy1,di1,sx,ffxp,fsxp,fwxp,xsize(1),xsize(2),xsize(3),1)
call derx (tc1,uz1,di1,sx,ffxp,fsxp,fwxp,xsize(1),xsize(2),xsize(3),1)
do ijk=1,nvect1
ta1(ijk,1,1)=0.5_mytype*td1(ijk,1,1)+0.5_mytype*ux1(ijk,1,1)*ta1(ijk,1,1)
tb1(ijk,1,1)=0.5_mytype*te1(ijk,1,1)+0.5_mytype*ux1(ijk,1,1)*tb1(ijk,1,1)
tc1(ijk,1,1)=0.5_mytype*tf1(ijk,1,1)+0.5_mytype*ux1(ijk,1,1)*tc1(ijk,1,1)
enddo
call transpose_x_to_y(ux1,ux2)
call transpose_x_to_y(uy1,uy2)
call transpose_x_to_y(uz1,uz2)
call transpose_x_to_y(ta1,ta2)
call transpose_x_to_y(tb1,tb2)
call transpose_x_to_y(tc1,tc2)
!WORK Y-PENCILS
do ijk=1,nvect2
td2(ijk,1,1)=ux2(ijk,1,1)*uy2(ijk,1,1)
te2(ijk,1,1)=uy2(ijk,1,1)*uy2(ijk,1,1)
tf2(ijk,1,1)=uz2(ijk,1,1)*uy2(ijk,1,1)
enddo
call dery (tg2,td2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
call dery (th2,te2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
call dery (ti2,tf2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
call dery (td2,ux2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
call dery (te2,uy2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
call dery (tf2,uz2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
do ijk=1,nvect2
ta2(ijk,1,1)=ta2(ijk,1,1)+0.5_mytype*tg2(ijk,1,1)+0.5_mytype*uy2(ijk,1,1)*td2(ijk,1,1)
tb2(ijk,1,1)=tb2(ijk,1,1)+0.5_mytype*th2(ijk,1,1)+0.5_mytype*uy2(ijk,1,1)*te2(ijk,1,1)
tc2(ijk,1,1)=tc2(ijk,1,1)+0.5_mytype*ti2(ijk,1,1)+0.5_mytype*uy2(ijk,1,1)*tf2(ijk,1,1)
enddo
call transpose_y_to_z(ux2,ux3)
call transpose_y_to_z(uy2,uy3)
call transpose_y_to_z(uz2,uz3)
call transpose_y_to_z(ta2,ta3)
call transpose_y_to_z(tb2,tb3)
call transpose_y_to_z(tc2,tc3)
!WORK Z-PENCILS
do ijk=1,nvect3
td3(ijk,1,1)=ux3(ijk,1,1)*uz3(ijk,1,1)
te3(ijk,1,1)=uy3(ijk,1,1)*uz3(ijk,1,1)
tf3(ijk,1,1)=uz3(ijk,1,1)*uz3(ijk,1,1)
enddo
call derz (tg3,td3,di3,sz,ffz,fsz,fwz,zsize(1),zsize(2),zsize(3),0)
call derz (th3,te3,di3,sz,ffz,fsz,fwz,zsize(1),zsize(2),zsize(3),0)
call derz (ti3,tf3,di3,sz,ffzp,fszp,fwzp,zsize(1),zsize(2),zsize(3),1)
call derz (td3,ux3,di3,sz,ffzp,fszp,fwzp,zsize(1),zsize(2),zsize(3),1)
call derz (te3,uy3,di3,sz,ffzp,fszp,fwzp,zsize(1),zsize(2),zsize(3),1)
call derz (tf3,uz3,di3,sz,ffz,fsz,fwz,zsize(1),zsize(2),zsize(3),0)
do ijk=1,nvect3
ta3(ijk,1,1)=ta3(ijk,1,1)+0.5_mytype*tg3(ijk,1,1)+0.5_mytype*uz3(ijk,1,1)*td3(ijk,1,1)
tb3(ijk,1,1)=tb3(ijk,1,1)+0.5_mytype*th3(ijk,1,1)+0.5_mytype*uz3(ijk,1,1)*te3(ijk,1,1)
tc3(ijk,1,1)=tc3(ijk,1,1)+0.5_mytype*ti3(ijk,1,1)+0.5_mytype*uz3(ijk,1,1)*tf3(ijk,1,1)
enddo
endif
!ALL THE CONVECTIVE TERMS ARE IN TA3, TB3 and TC3
!!! CM call test_min_max('td3 ','In convdiff ',td3,size(td3))
!!! CM call test_min_max('te3 ','In convdiff ',te3,size(te3))
!!! CM call test_min_max('tf3 ','In convdiff ',tf3,size(tf3))
td3(:,:,:)=ta3(:,:,:)
te3(:,:,:)=tb3(:,:,:)
tf3(:,:,:)=tc3(:,:,:)
!DIFFUSIVE TERMS IN Z
call derzz (ta3,ux3,di3,sz,sfzp,sszp,swzp,zsize(1),zsize(2),zsize(3),1)
call derzz (tb3,uy3,di3,sz,sfzp,sszp,swzp,zsize(1),zsize(2),zsize(3),1)
call derzz (tc3,uz3,di3,sz,sfz ,ssz ,swz ,zsize(1),zsize(2),zsize(3),0)
!!! CM call test_min_max('ta3 ','In convdiff ',ta3,size(ta3))
!!! CM call test_min_max('tb3 ','In convdiff ',tb3,size(tb3))
!!! CM call test_min_max('tc3 ','In convdiff ',tc3,size(tc3))
!WORK Y-PENCILS
call transpose_z_to_y(ta3,ta2)
call transpose_z_to_y(tb3,tb2)
call transpose_z_to_y(tc3,tc2)
call transpose_z_to_y(td3,td2)
call transpose_z_to_y(te3,te2)
call transpose_z_to_y(tf3,tf2)
tg2(:,:,:)=td2(:,:,:)
th2(:,:,:)=te2(:,:,:)
ti2(:,:,:)=tf2(:,:,:)
!!! CM call test_min_max('tg2 ','In convdiff ',tg2,size(tg2))
!!! CM call test_min_max('th2 ','In convdiff ',th2,size(th2))
!!! CM call test_min_max('ti2 ','In convdiff ',ti2,size(ti2))
!DIFFUSIVE TERMS IN Y
!-->for ux
if (istret.ne.0) then
call deryy (td2,ux2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
call dery (te2,ux2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
do k=1,ysize(3)
do j=1,ysize(2)
do i=1,ysize(1)
td2(i,j,k)=td2(i,j,k)*pp2y(j)-pp4y(j)*te2(i,j,k)
enddo
enddo
enddo
else
!!! CM call test_min_max('ux2 ','In convdiff ',ux2,size(ux2))
!!! CM call test_min_max('di2 ','In convdiff ',di2,size(di2))
!!! CM write(*,*) ysize(1),ysize(2),ysize(3)
call deryy (td2,ux2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
endif
!!! CM call test_min_max('td2 ','In convdiff ',td2,size(td2))
!-->for uy
if (istret.ne.0) then
call deryy (te2,uy2,di2,sy,sfy,ssy,swy,ysize(1),ysize(2),ysize(3),0)
call dery (tf2,uy2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
do k=1,ysize(3)
do j=1,ysize(2)
do i=1,ysize(1)
te2(i,j,k)=te2(i,j,k)*pp2y(j)-pp4y(j)*tf2(i,j,k)
enddo
enddo
enddo
else
call deryy (te2,uy2,di2,sy,sfy,ssy,swy,ysize(1),ysize(2),ysize(3),0)
endif
!-->for uz
if (istret.ne.0) then
call deryy (tf2,uz2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
call dery (tj2,uz2,di2,sy,ffyp,fsyp,fwyp,ppy,ysize(1),ysize(2),ysize(3),1)
do k=1,ysize(3)
do j=1,ysize(2)
do i=1,ysize(1)
tf2(i,j,k)=tf2(i,j,k)*pp2y(j)-pp4y(j)*tj2(i,j,k)
enddo
enddo
enddo
else
call deryy (tf2,uz2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
endif
!!! CM call test_min_max('td2 ','In convdiff ',td2,size(td2))
!!! CM call test_min_max('te2 ','In convdiff ',te2,size(te2))
!!! CM call test_min_max('tf2 ','In convdiff ',tf2,size(tf2))
ta2(:,:,:)=ta2(:,:,:)+td2(:,:,:)
tb2(:,:,:)=tb2(:,:,:)+te2(:,:,:)
tc2(:,:,:)=tc2(:,:,:)+tf2(:,:,:)
!!! CM call test_min_max('ta2 ','In convdiff ',ta2,size(ta2))
!!! CM call test_min_max('tb2 ','In convdiff ',tb2,size(tb2))
!!! CM call test_min_max('tc2 ','In convdiff ',tc2,size(tc2))
!WORK X-PENCILS
call transpose_y_to_x(ta2,ta1)
call transpose_y_to_x(tb2,tb1)
call transpose_y_to_x(tc2,tc1) !diff
call transpose_y_to_x(tg2,td1)
call transpose_y_to_x(th2,te1)
call transpose_y_to_x(ti2,tf1) !conv
tg1(:,:,:)=td1(:,:,:)
th1(:,:,:)=te1(:,:,:)
ti1(:,:,:)=tf1(:,:,:)
!DIFFUSIVE TERMS IN X
call derxx (td1,ux1,di1,sx,sfx ,ssx ,swx ,xsize(1),xsize(2),xsize(3),0)
call derxx (te1,uy1,di1,sx,sfxp,ssxp,swxp,xsize(1),xsize(2),xsize(3),1)
call derxx (tf1,uz1,di1,sx,sfxp,ssxp,swxp,xsize(1),xsize(2),xsize(3),1)
ta1(:,:,:)=ta1(:,:,:)+td1(:,:,:)
tb1(:,:,:)=tb1(:,:,:)+te1(:,:,:)
tc1(:,:,:)=tc1(:,:,:)+tf1(:,:,:)
!if (nrank==1) print *,'ATTENTION ATTENTION canal tournant',itime
!tg1(:,:,:)=tg1(:,:,:)-2./18.*uy1(:,:,:)
!th1(:,:,:)=th1(:,:,:)-2./18.*ux1(:,:,:)
!FINAL SUM: DIFF TERMS + CONV TERMS
ta1(:,:,:)=xnu*ta1(:,:,:)-tg1(:,:,:)
tb1(:,:,:)=xnu*tb1(:,:,:)-th1(:,:,:)
tc1(:,:,:)=xnu*tc1(:,:,:)-ti1(:,:,:)
ta1max=-1.e30_mytype
ta1min=+1.e30_mytype
tb1max=-1.e30_mytype
tb1min=+1.e30_mytype
tc1max=-1.e30_mytype
tc1min=+1.e30_mytype
do k=xstart(3),xend(3)
do j=xstart(2),xend(2)
do i=xstart(1),xend(1)
if (ta1(i,j,k).gt.ta1max) ta1max=ta1(i,j,k)
if (ta1(i,j,k).lt.ta1min) ta1min=ta1(i,j,k)
if (tb1(i,j,k).gt.tb1max) tb1max=tb1(i,j,k)
if (tb1(i,j,k).lt.tb1min) tb1min=tb1(i,j,k)
if (tc1(i,j,k).gt.tc1max) tc1max=tc1(i,j,k)
if (tc1(i,j,k).lt.tc1min) tc1min=tc1(i,j,k)
enddo
enddo
enddo
call MPI_REDUCE(ta1max,ta1max1,1,real_type,MPI_MAX,0,MPI_COMM_WORLD,code)
call MPI_REDUCE(ta1min,ta1min1,1,real_type,MPI_MIN,0,MPI_COMM_WORLD,code)
call MPI_REDUCE(tb1max,tb1max1,1,real_type,MPI_MAX,0,MPI_COMM_WORLD,code)
call MPI_REDUCE(tb1min,tb1min1,1,real_type,MPI_MIN,0,MPI_COMM_WORLD,code)
call MPI_REDUCE(tc1max,tc1max1,1,real_type,MPI_MAX,0,MPI_COMM_WORLD,code)
call MPI_REDUCE(tc1min,tc1min1,1,real_type,MPI_MIN,0,MPI_COMM_WORLD,code)
!!! CM if (nrank==0) then
!!! CM write(*,*) 'In convdiff ta1',ta1max1,ta1min1
!!! CM write(*,*) 'In convdiff tb1',tb1max1,tb1min1
!!! CM write(*,*) 'In convdiff tc1',tc1max1,tc1min1
!!! CM endif
end subroutine convdiff
!************************************************************
!
subroutine scalar(ux1,uy1,uz1,phi1,phis1,phiss1,di1,ta1,tb1,tc1,td1,&
uy2,uz2,phi2,di2,ta2,tb2,tc2,td2,uz3,phi3,di3,ta3,tb3,epsi)
!
!************************************************************
USE param
USE variables
USE decomp_2d
implicit none
real(mytype),dimension(xsize(1),xsize(2),xsize(3)) :: ux1,uy1,uz1,phi1,phis1,&
phiss1,di1,ta1,tb1,tc1,td1,epsi
real(mytype),dimension(ysize(1),ysize(2),ysize(3)) :: uy2,uz2,phi2,di2,ta2,tb2,tc2,td2
real(mytype),dimension(zsize(1),zsize(2),zsize(3)) :: uz3,phi3,di3,ta3,tb3
integer :: ijk,nvect1,nvect2,nvect3,i,j,k,nxyz
real(mytype) :: x,y,z
nvect1=xsize(1)*xsize(2)*xsize(3)
nvect2=ysize(1)*ysize(2)*ysize(3)
nvect3=zsize(1)*zsize(2)*zsize(3)
!X PENCILS
do ijk=1,nvect1
ta1(ijk,1,1)=ux1(ijk,1,1)*phi1(ijk,1,1)
enddo
call derx (tb1,ta1,di1,sx,ffx,fsx,fwx,xsize(1),xsize(2),xsize(3),0)
call derxx (ta1,phi1,di1,sx,sfxp,ssxp,swxp,xsize(1),xsize(2),xsize(3),1)
call transpose_x_to_y(phi1,phi2)
call transpose_x_to_y(uy1,uy2)
call transpose_x_to_y(uz1,uz2)
!Y PENCILS
do ijk=1,nvect2
ta2(ijk,1,1)=uy2(ijk,1,1)*phi2(ijk,1,1)
enddo
call dery (tb2,ta2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
if (istret.ne.0) then
call deryy (ta2,phi2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
call dery (tc2,phi2,di2,sy,ffy,fsy,fwy,ppy,ysize(1),ysize(2),ysize(3),0)
do k=1,ysize(3)
do j=1,ysize(2)
do i=1,ysize(1)
ta2(i,j,k)=ta2(i,j,k)*pp2y(j)-pp4y(j)*tc2(i,j,k)
enddo
enddo
enddo
else
call deryy (ta2,phi2,di2,sy,sfyp,ssyp,swyp,ysize(1),ysize(2),ysize(3),1)
endif
call transpose_y_to_z(phi2,phi3)
call transpose_y_to_z(uz2,uz3)
!Z PENCILS
do ijk=1,nvect3
ta3(ijk,1,1)=uz3(ijk,1,1)*phi3(ijk,1,1)
enddo
call derz (tb3,ta3,di3,sz,ffz,fsz,fwz,zsize(1),zsize(2),zsize(3),0)
call derzz (ta3,phi3,di3,sz,sfzp,sszp,swzp,zsize(1),zsize(2),zsize(3),1)
call transpose_z_to_y(ta3,tc2)
call transpose_z_to_y(tb3,td2)
!Y PENCILS ADD TERMS
do ijk=1,nvect2
tc2(ijk,1,1)=tc2(ijk,1,1)+ta2(ijk,1,1)
td2(ijk,1,1)=td2(ijk,1,1)+tb2(ijk,1,1)
enddo
call transpose_y_to_x(tc2,tc1)
call transpose_y_to_x(td2,td1)
!X PENCILS ADD TERMS
do ijk=1,nvect1
ta1(ijk,1,1)=ta1(ijk,1,1)+tc1(ijk,1,1) !SECOND DERIVATIVE
tb1(ijk,1,1)=tb1(ijk,1,1)+td1(ijk,1,1) !FIRST DERIVATIVE
enddo
do ijk=1,nvect1
ta1(ijk,1,1)=xnu/sc*ta1(ijk,1,1)-tb1(ijk,1,1)
enddo
!TIME ADVANCEMENT
nxyz=xsize(1)*xsize(2)*xsize(3)
if ((nscheme.eq.1).or.(nscheme.eq.2)) then
if ((nscheme.eq.1.and.itime.eq.1.and.ilit.eq.0).or.&
(nscheme.eq.2.and.itr.eq.1)) then
do ijk=1,nxyz
phi1(ijk,1,1)=gdt(itr)*ta1(ijk,1,1)+phi1(ijk,1,1)
phis1(ijk,1,1)=ta1(ijk,1,1)
enddo
else
do ijk=1,nxyz
phi1(ijk,1,1)=adt(itr)*ta1(ijk,1,1)+bdt(itr)*phis1(ijk,1,1)+phi1(ijk,1,1)
phis1(ijk,1,1)=ta1(ijk,1,1)
enddo
endif
endif
if (nscheme.eq.3) then
if (nrank==0) print *,'Not ready'
stop
endif
if (nscheme==4) then
if ((itime.eq.1).and.(ilit.eq.0)) then
if (nrank==0) print *,'start with Euler',itime
do ijk=1,nxyz !start with Euler
phi1(ijk,1,1)=dt*ta1(ijk,1,1)+phi1(ijk,1,1)
phis1(ijk,1,1)=ta1(ijk,1,1)
enddo
else
if ((itime.eq.2).and.(ilit.eq.0)) then
if (nrank==0) print *,'then with AB2',itime
do ijk=1,nxyz
phi1(ijk,1,1)=1.5_mytype*dt*ta1(ijk,1,1)-0.5_mytype*dt*phis1(ijk,1,1)+phi1(ijk,1,1)
phiss1(ijk,1,1)=phis1(ijk,1,1)
phis1(ijk,1,1)=ta1(ijk,1,1)
enddo
else
do ijk=1,nxyz
phi1(ijk,1,1)=adt(itr)*ta1(ijk,1,1)+bdt(itr)*phis1(ijk,1,1)+&
cdt(itr)*phiss1(ijk,1,1)+phi1(ijk,1,1)
phiss1(ijk,1,1)=phis1(ijk,1,1)
phis1(ijk,1,1)=ta1(ijk,1,1)
enddo
endif
endif
endif
end subroutine scalar
decomp_2d.f90 0000644 0001750 0001750 00000157447 13051023554 013162 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! This is the main 2D pencil decomposition module
module decomp_2d
use MPI
implicit none
private ! Make everything private unless declared public
#ifdef DOUBLE_PREC
integer, parameter, public :: mytype = KIND(0.0D0)
integer, parameter, public :: real_type = MPI_DOUBLE_PRECISION
integer, parameter, public :: complex_type = MPI_DOUBLE_COMPLEX
#else
integer, parameter, public :: mytype = KIND(0.0)
integer, parameter, public :: real_type = MPI_REAL
integer, parameter, public :: complex_type = MPI_COMPLEX
#endif
integer, save, public :: mytype_bytes
! some key global variables
integer, save, public :: nx_global, ny_global, nz_global ! global size
integer, save, public :: nrank ! local MPI rank
integer, save, public :: nproc ! total number of processors
! parameters for 2D Cartesian topology
integer, save, dimension(2) :: dims, coord
logical, save, dimension(2) :: periodic
integer, save, public :: DECOMP_2D_COMM_CART_X, &
DECOMP_2D_COMM_CART_Y, DECOMP_2D_COMM_CART_Z
integer, save :: DECOMP_2D_COMM_ROW, DECOMP_2D_COMM_COL
! define neighboring blocks (to be used in halo-cell support)
! first dimension 1=X-pencil, 2=Y-pencil, 3=Z-pencil
! second dimension 1=east, 2=west, 3=north, 4=south, 5=top, 6=bottom
integer, save, dimension(3,6) :: neighbour
! flags for periodic condition in three dimensions
logical, save :: periodic_x, periodic_y, periodic_z
#ifdef SHM
! derived type to store shared-memory info
TYPE, public :: SMP_INFO
integer MPI_COMM ! SMP associated with this communicator
integer NODE_ME ! rank in this communicator
integer NCPU ! size of this communicator
integer SMP_COMM ! communicator for SMP-node masters
integer CORE_COMM ! communicator for cores on SMP-node
integer SMP_ME ! SMP-node id starting from 1 ... NSMP
integer NSMP ! number of SMP-nodes in this communicator
integer CORE_ME ! core id starting from 1 ... NCORE
integer NCORE ! number of cores on this SMP-node
integer MAXCORE ! maximum no. cores on any SMP-node
integer N_SND ! size of SMP shared memory buffer
integer N_RCV ! size of SMP shared memory buffer
integer(8) SND_P ! SNDBUF address (cray pointer), for real
integer(8) RCV_P ! RCVBUF address (cray pointer), for real
integer(8) SND_P_c ! for complex
integer(8) RCV_P_c ! for complex
END TYPE SMP_INFO
#endif
! derived type to store decomposition info for a given global data size
TYPE, public :: DECOMP_INFO
! staring/ending index and size of data held by current processor
integer, dimension(3) :: xst, xen, xsz ! x-pencil
integer, dimension(3) :: yst, yen, ysz ! y-pencil
integer, dimension(3) :: zst, zen, zsz ! z-pencil
! in addition to local information, processors also need to know
! some global information for global communications to work
! how each dimension is distributed along pencils
integer, allocatable, dimension(:) :: &
x1dist, y1dist, y2dist, z2dist
! send/receive buffer counts and displacements for MPI_ALLTOALLV
integer, allocatable, dimension(:) :: &
x1cnts, y1cnts, y2cnts, z2cnts
integer, allocatable, dimension(:) :: &
x1disp, y1disp, y2disp, z2disp
! buffer counts for MPI_ALLTOALL: either for evenly distributed data
! or for padded-alltoall
integer :: x1count, y1count, y2count, z2count
! evenly distributed data
logical :: even
#ifdef SHM
! For shared-memory implementation
! one instance of this derived type for each communicator
! shared moemory info, such as which MPI rank belongs to which node
TYPE(SMP_INFO) :: ROW_INFO, COL_INFO
! shared send/recv buffers for ALLTOALLV
integer, allocatable, dimension(:) :: x1cnts_s, y1cnts_s, &
y2cnts_s, z2cnts_s
integer, allocatable, dimension(:) :: x1disp_s, y1disp_s, &
y2disp_s, z2disp_s
! A copy of original buffer displacement (will be overwriten)
integer, allocatable, dimension(:) :: x1disp_o, y1disp_o, &
y2disp_o, z2disp_o
#endif
END TYPE DECOMP_INFO
! main (default) decomposition information for global size nx*ny*nz
TYPE(DECOMP_INFO), save :: decomp_main
! staring/ending index and size of data held by current processor
! duplicate 'decomp_main', needed by apps to define data structure
integer, save, dimension(3), public :: xstart, xend, xsize ! x-pencil
integer, save, dimension(3), public :: ystart, yend, ysize ! y-pencil
integer, save, dimension(3), public :: zstart, zend, zsize ! z-pencil
! These are the buffers used by MPI_ALLTOALL(V) calls
integer, save :: decomp_buf_size = 0
real(mytype), allocatable, dimension(:) :: work1_r, work2_r
complex(mytype), allocatable, dimension(:) :: work1_c, work2_c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! To define smaller arrays using every several mesh points
integer, save, dimension(3), public :: xszS,yszS,zszS,xstS,ystS,zstS,xenS,yenS,zenS
integer, save, dimension(3), public :: xszV,yszV,zszV,xstV,ystV,zstV,xenV,yenV,zenV
integer, save, dimension(3), public :: xszP,yszP,zszP,xstP,ystP,zstP,xenP,yenP,zenP
logical, save :: coarse_mesh_starts_from_1
integer, save :: iskipS, jskipS, kskipS
integer, save :: iskipV, jskipV, kskipV
integer, save :: iskipP, jskipP, kskipP
! public user routines
public :: decomp_2d_init, decomp_2d_finalize, &
transpose_x_to_y, transpose_y_to_z, &
transpose_z_to_y, transpose_y_to_x, &
#ifdef OCC
transpose_x_to_y_start, transpose_y_to_z_start, &
transpose_z_to_y_start, transpose_y_to_x_start, &
transpose_x_to_y_wait, transpose_y_to_z_wait, &
transpose_z_to_y_wait, transpose_y_to_x_wait, &
transpose_test, &
#endif
decomp_info_init, decomp_info_finalize, partition, &
init_coarser_mesh_statS,fine_to_coarseS,&
init_coarser_mesh_statV,fine_to_coarseV,&
init_coarser_mesh_statP,fine_to_coarseP,&
alloc_x, alloc_y, alloc_z, &
update_halo, decomp_2d_abort, &
get_decomp_info
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! These are routines to perform global data transpositions
!
! Four combinations are available, enough to cover all situations
! - transpose_x_to_y (X-pencil --> Y-pencil)
! - transpose_y_to_z (Y-pencil --> Z-pencil)
! - transpose_z_to_y (Z-pencil --> Y-pencil)
! - transpose_y_to_x (Y-pencil --> X-pencil)
!
! Generic interface provided here to support multiple data types
! - real and complex types supported through generic interface
! - single/double precision supported through pre-processing
! * see 'mytype' variable at the beginning
! - an optional argument can be supplied to transpose data whose
! global size is not the default nx*ny*nz
! * as the case in fft r2c/c2r interface
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
interface transpose_x_to_y
module procedure transpose_x_to_y_real
module procedure transpose_x_to_y_complex
end interface transpose_x_to_y
interface transpose_y_to_z
module procedure transpose_y_to_z_real
module procedure transpose_y_to_z_complex
end interface transpose_y_to_z
interface transpose_z_to_y
module procedure transpose_z_to_y_real
module procedure transpose_z_to_y_complex
end interface transpose_z_to_y
interface transpose_y_to_x
module procedure transpose_y_to_x_real
module procedure transpose_y_to_x_complex
end interface transpose_y_to_x
#ifdef OCC
interface transpose_x_to_y_start
module procedure transpose_x_to_y_real_start
module procedure transpose_x_to_y_complex_start
end interface transpose_x_to_y_start
interface transpose_y_to_z_start
module procedure transpose_y_to_z_real_start
module procedure transpose_y_to_z_complex_start
end interface transpose_y_to_z_start
interface transpose_z_to_y_start
module procedure transpose_z_to_y_real_start
module procedure transpose_z_to_y_complex_start
end interface transpose_z_to_y_start
interface transpose_y_to_x_start
module procedure transpose_y_to_x_real_start
module procedure transpose_y_to_x_complex_start
end interface transpose_y_to_x_start
interface transpose_x_to_y_wait
module procedure transpose_x_to_y_real_wait
module procedure transpose_x_to_y_complex_wait
end interface transpose_x_to_y_wait
interface transpose_y_to_z_wait
module procedure transpose_y_to_z_real_wait
module procedure transpose_y_to_z_complex_wait
end interface transpose_y_to_z_wait
interface transpose_z_to_y_wait
module procedure transpose_z_to_y_real_wait
module procedure transpose_z_to_y_complex_wait
end interface transpose_z_to_y_wait
interface transpose_y_to_x_wait
module procedure transpose_y_to_x_real_wait
module procedure transpose_y_to_x_complex_wait
end interface transpose_y_to_x_wait
#endif
interface update_halo
module procedure update_halo_real
module procedure update_halo_complex
end interface update_halo
interface alloc_x
module procedure alloc_x_real
module procedure alloc_x_complex
end interface alloc_x
interface alloc_y
module procedure alloc_y_real
module procedure alloc_y_complex
end interface alloc_y
interface alloc_z
module procedure alloc_z_real
module procedure alloc_z_complex
end interface alloc_z
contains
#ifdef SHM_DEBUG
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! For debugging, print the shared-memory structure
subroutine print_smp_info(s)
TYPE(SMP_INFO) :: s
write(10,*) 'size of current communicator:', s%NCPU
write(10,*) 'rank in current communicator:', s%NODE_ME
write(10,*) 'number of SMP-nodes in this communicator:', s%NSMP
write(10,*) 'SMP-node id (1 ~ NSMP):', s%SMP_ME
write(10,*) 'NCORE - number of cores on this SMP-node', s%NCORE
write(10,*) 'core id (1 ~ NCORE):', s%CORE_ME
write(10,*) 'maximum no. cores on any SMP-node:', s%MAXCORE
write(10,*) 'size of SMP shared memory SND buffer:', s%N_SND
write(10,*) 'size of SMP shared memory RCV buffer:', s%N_RCV
end subroutine print_smp_info
#endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Routine to be called by applications to initialise this library
! INPUT:
! nx, ny, nz - global data dimension
! p_row, p_col - 2D processor grid
! OUTPUT:
! all internal data structures initialised properly
! library ready to use
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_2d_init(nx,ny,nz,p_row,p_col,periodic_bc)
implicit none
integer, intent(IN) :: nx,ny,nz,p_row,p_col
logical, dimension(3), intent(IN), optional :: periodic_bc
integer :: errorcode, ierror, row, col
#ifdef SHM_DEBUG
character(len=80) fname
#endif
nx_global = nx
ny_global = ny
nz_global = nz
if (present(periodic_bc)) then
periodic_x = periodic_bc(1)
periodic_y = periodic_bc(2)
periodic_z = periodic_bc(3)
else
periodic_x = .false.
periodic_y = .false.
periodic_z = .false.
end if
call MPI_COMM_RANK(MPI_COMM_WORLD,nrank,ierror)
call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ierror)
if (p_row==0 .and. p_col==0) then
! determine the best 2D processor grid
call best_2d_grid(nproc, row, col)
else
if (nproc /= p_row*p_col) then
errorcode = 1
call decomp_2d_abort(errorcode, &
'Invalid 2D processor grid - nproc /= p_row*p_col')
else
row = p_row
col = p_col
end if
end if
! Create 2D Catersian topology
! Note that in order to support periodic B.C. in the halo-cell code,
! need to create multiple topology objects: DECOMP_2D_COMM_CART_?,
! corresponding to three pencil orientations. They contain almost
! identical topological information but allow different combinations
! of periodic conditions.
dims(1) = row
dims(2) = col
periodic(1) = periodic_y
periodic(2) = periodic_z
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., & ! do not reorder rank
DECOMP_2D_COMM_CART_X, ierror)
periodic(1) = periodic_x
periodic(2) = periodic_z
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., DECOMP_2D_COMM_CART_Y, ierror)
periodic(1) = periodic_x
periodic(2) = periodic_y
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., DECOMP_2D_COMM_CART_Z, ierror)
call MPI_CART_COORDS(DECOMP_2D_COMM_CART_X,nrank,2,coord,ierror)
! derive communicators defining sub-groups for ALLTOALL(V)
call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.true.,.false./), &
DECOMP_2D_COMM_COL,ierror)
call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.false.,.true./), &
DECOMP_2D_COMM_ROW,ierror)
! gather information for halo-cell support code
call init_neighbour
! actually generate all 2D decomposition information
call decomp_info_init(nx,ny,nz,decomp_main)
! make a copy of the decomposition information associated with the
! default global size in these global variables so applications can
! use them to create data structures
xstart = decomp_main%xst
ystart = decomp_main%yst
zstart = decomp_main%zst
xend = decomp_main%xen
yend = decomp_main%yen
zend = decomp_main%zen
xsize = decomp_main%xsz
ysize = decomp_main%ysz
zsize = decomp_main%zsz
#ifdef SHM_DEBUG
! print out shared-memory information
write(fname,99) nrank
99 format('log',I2.2)
open(10,file=fname)
write(10,*)'I am mpi rank ', nrank, 'Total ranks ', nproc
write(10,*)' '
write(10,*)'Global data size:'
write(10,*)'nx*ny*nz', nx,ny,nz
write(10,*)' '
write(10,*)'2D processor grid:'
write(10,*)'p_row*p_col:', dims(1), dims(2)
write(10,*)' '
write(10,*)'Portion of global data held locally:'
write(10,*)'xsize:',xsize
write(10,*)'ysize:',ysize
write(10,*)'zsize:',zsize
write(10,*)' '
write(10,*)'How pensils are to be divided and sent in alltoallv:'
write(10,*)'x1dist:',decomp_main%x1dist
write(10,*)'y1dist:',decomp_main%y1dist
write(10,*)'y2dist:',decomp_main%y2dist
write(10,*)'z2dist:',decomp_main%z2dist
write(10,*)' '
write(10,*)'######Shared buffer set up after this point######'
write(10,*)' '
write(10,*) 'col communicator detais:'
call print_smp_info(decomp_main%COL_INFO)
write(10,*)' '
write(10,*) 'row communicator detais:'
call print_smp_info(decomp_main%ROW_INFO)
write(10,*)' '
write(10,*)'Buffer count and dispalcement of per-core buffers'
write(10,*)'x1cnts:',decomp_main%x1cnts
write(10,*)'y1cnts:',decomp_main%y1cnts
write(10,*)'y2cnts:',decomp_main%y2cnts
write(10,*)'z2cnts:',decomp_main%z2cnts
write(10,*)'x1disp:',decomp_main%x1disp
write(10,*)'y1disp:',decomp_main%y1disp
write(10,*)'y2disp:',decomp_main%y2disp
write(10,*)'z2disp:',decomp_main%z2disp
write(10,*)' '
write(10,*)'Buffer count and dispalcement of shared buffers'
write(10,*)'x1cnts:',decomp_main%x1cnts_s
write(10,*)'y1cnts:',decomp_main%y1cnts_s
write(10,*)'y2cnts:',decomp_main%y2cnts_s
write(10,*)'z2cnts:',decomp_main%z2cnts_s
write(10,*)'x1disp:',decomp_main%x1disp_s
write(10,*)'y1disp:',decomp_main%y1disp_s
write(10,*)'y2disp:',decomp_main%y2disp_s
write(10,*)'z2disp:',decomp_main%z2disp_s
write(10,*)' '
close(10)
#endif
! determine the number of bytes per float number
! do not use 'mytype' which is compiler dependent
! also possible to use inquire(iolength=...)
call MPI_TYPE_SIZE(real_type,mytype_bytes,ierror)
#ifdef EVEN
if (nrank==0) write(*,*) 'Padded ALLTOALL optimisation on'
#endif
return
end subroutine decomp_2d_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Routine to be called by applications to clean things up
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_2d_finalize
implicit none
call decomp_info_finalize(decomp_main)
decomp_buf_size = 0
deallocate(work1_r, work2_r, work1_c, work2_c)
return
end subroutine decomp_2d_finalize
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Return the default decomposition object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine get_decomp_info(decomp)
implicit none
TYPE(DECOMP_INFO), intent(OUT) :: decomp
decomp = decomp_main
return
end subroutine get_decomp_info
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Advanced Interface allowing applications to define globle domain of
! any size, distribute it, and then transpose data among pencils.
! - generate 2D decomposition details as defined in DECOMP_INFO
! - the default global data size is nx*ny*nz
! - a different global size nx/2+1,ny,nz is used in FFT r2c/c2r
! - multiple global sizes can co-exist in one application, each
! using its own DECOMP_INFO object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_info_init(nx,ny,nz,decomp)
implicit none
integer, intent(IN) :: nx,ny,nz
TYPE(DECOMP_INFO), intent(INOUT) :: decomp
integer :: buf_size, status, errorcode
! verify the global size can actually be distributed as pencils
if (nx= p_row and ' // &
'min(ny,nz) >= p_col')
end if
if (mod(nx,dims(1))==0 .and. mod(ny,dims(1))==0 .and. &
mod(ny,dims(2))==0 .and. mod(nz,dims(2))==0) then
decomp%even = .true.
else
decomp%even = .false.
end if
! distribute mesh points
allocate(decomp%x1dist(0:dims(1)-1),decomp%y1dist(0:dims(1)-1), &
decomp%y2dist(0:dims(2)-1),decomp%z2dist(0:dims(2)-1))
call get_dist(nx,ny,nz,decomp)
! generate partition information - starting/ending index etc.
call partition(nx, ny, nz, (/ 1,2,3 /), &
decomp%xst, decomp%xen, decomp%xsz)
call partition(nx, ny, nz, (/ 2,1,3 /), &
decomp%yst, decomp%yen, decomp%ysz)
call partition(nx, ny, nz, (/ 2,3,1 /), &
decomp%zst, decomp%zen, decomp%zsz)
! prepare send/receive buffer displacement and count for ALLTOALL(V)
allocate(decomp%x1cnts(0:dims(1)-1),decomp%y1cnts(0:dims(1)-1), &
decomp%y2cnts(0:dims(2)-1),decomp%z2cnts(0:dims(2)-1))
allocate(decomp%x1disp(0:dims(1)-1),decomp%y1disp(0:dims(1)-1), &
decomp%y2disp(0:dims(2)-1),decomp%z2disp(0:dims(2)-1))
call prepare_buffer(decomp)
#ifdef SHM
! prepare shared-memory information if required
call decomp_info_init_shm(decomp)
#endif
! allocate memory for the MPI_ALLTOALL(V) buffers
! define the buffers globally for performance reason
buf_size = max(decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3), &
max(decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3), &
decomp%zsz(1)*decomp%zsz(2)*decomp%zsz(3)) )
#ifdef EVEN
! padded alltoall optimisation may need larger buffer space
buf_size = max(buf_size, &
max(decomp%x1count*dims(1),decomp%y2count*dims(2)) )
#endif
! check if additional memory is required
! *** TODO: consider how to share the real/complex buffers
if (buf_size > decomp_buf_size) then
decomp_buf_size = buf_size
if (allocated(work1_r)) deallocate(work1_r)
if (allocated(work2_r)) deallocate(work2_r)
if (allocated(work1_c)) deallocate(work1_c)
if (allocated(work2_c)) deallocate(work2_c)
allocate(work1_r(buf_size), STAT=status)
allocate(work2_r(buf_size), STAT=status)
allocate(work1_c(buf_size), STAT=status)
allocate(work2_c(buf_size), STAT=status)
if (status /= 0) then
errorcode = 2
call decomp_2d_abort(errorcode, &
'Out of memory when allocating 2DECOMP workspace')
end if
end if
return
end subroutine decomp_info_init
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Release memory associated with a DECOMP_INFO object
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_info_finalize(decomp)
implicit none
TYPE(DECOMP_INFO), intent(INOUT) :: decomp
deallocate(decomp%x1dist,decomp%y1dist,decomp%y2dist,decomp%z2dist)
deallocate(decomp%x1cnts,decomp%y1cnts,decomp%y2cnts,decomp%z2cnts)
deallocate(decomp%x1disp,decomp%y1disp,decomp%y2disp,decomp%z2disp)
#ifdef SHM
deallocate(decomp%x1disp_o,decomp%y1disp_o,decomp%y2disp_o, &
decomp%z2disp_o)
deallocate(decomp%x1cnts_s,decomp%y1cnts_s,decomp%y2cnts_s, &
decomp%z2cnts_s)
deallocate(decomp%x1disp_s,decomp%y1disp_s,decomp%y2disp_s, &
decomp%z2disp_s)
#endif
return
end subroutine decomp_info_finalize
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Coarser mesh support for statistic
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine init_coarser_mesh_statS(i_skip,j_skip,k_skip,from1)
implicit none
integer, intent(IN) :: i_skip,j_skip,k_skip
logical, intent(IN) :: from1 ! .true. - save 1,n+1,2n+1...
! .false. - save n,2n,3n...
integer, dimension(3) :: skip
integer :: i
coarse_mesh_starts_from_1 = from1
iskipS = i_skip
jskipS = j_skip
kskipS = k_skip
skip(1)=iskipS
skip(2)=jskipS
skip(3)=kskipS
do i=1,3
if (from1) then
xstS(i) = (xstart(i)+skip(i)-1)/skip(i)
if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstS(i)=xstS(i)+1
xenS(i) = (xend(i)+skip(i)-1)/skip(i)
else
xstS(i) = xstart(i)/skip(i)
if (mod(xstart(i),skip(i))/=0) xstS(i)=xstS(i)+1
xenS(i) = xend(i)/skip(i)
end if
xszS(i) = xenS(i)-xstS(i)+1
end do
do i=1,3
if (from1) then
ystS(i) = (ystart(i)+skip(i)-1)/skip(i)
if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystS(i)=ystS(i)+1
yenS(i) = (yend(i)+skip(i)-1)/skip(i)
else
ystS(i) = ystart(i)/skip(i)
if (mod(ystart(i),skip(i))/=0) ystS(i)=ystS(i)+1
yenS(i) = yend(i)/skip(i)
end if
yszS(i) = yenS(i)-ystS(i)+1
end do
do i=1,3
if (from1) then
zstS(i) = (zstart(i)+skip(i)-1)/skip(i)
if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstS(i)=zstS(i)+1
zenS(i) = (zend(i)+skip(i)-1)/skip(i)
else
zstS(i) = zstart(i)/skip(i)
if (mod(zstart(i),skip(i))/=0) zstS(i)=zstS(i)+1
zenS(i) = zend(i)/skip(i)
end if
zszS(i) = zenS(i)-zstS(i)+1
end do
return
end subroutine init_coarser_mesh_statS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Coarser mesh support for visualization
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine init_coarser_mesh_statV(i_skip,j_skip,k_skip,from1)
implicit none
integer, intent(IN) :: i_skip,j_skip,k_skip
logical, intent(IN) :: from1 ! .true. - save 1,n+1,2n+1...
! .false. - save n,2n,3n...
integer, dimension(3) :: skip
integer :: i
coarse_mesh_starts_from_1 = from1
iskipV = i_skip
jskipV = j_skip
kskipV = k_skip
skip(1)=iskipV
skip(2)=jskipV
skip(3)=kskipV
do i=1,3
if (from1) then
xstV(i) = (xstart(i)+skip(i)-1)/skip(i)
if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstV(i)=xstV(i)+1
xenV(i) = (xend(i)+skip(i)-1)/skip(i)
else
xstV(i) = xstart(i)/skip(i)
if (mod(xstart(i),skip(i))/=0) xstV(i)=xstV(i)+1
xenV(i) = xend(i)/skip(i)
end if
xszV(i) = xenV(i)-xstV(i)+1
end do
do i=1,3
if (from1) then
ystV(i) = (ystart(i)+skip(i)-1)/skip(i)
if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystV(i)=ystV(i)+1
yenV(i) = (yend(i)+skip(i)-1)/skip(i)
else
ystV(i) = ystart(i)/skip(i)
if (mod(ystart(i),skip(i))/=0) ystV(i)=ystV(i)+1
yenV(i) = yend(i)/skip(i)
end if
yszV(i) = yenV(i)-ystV(i)+1
end do
do i=1,3
if (from1) then
zstV(i) = (zstart(i)+skip(i)-1)/skip(i)
if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstV(i)=zstV(i)+1
zenV(i) = (zend(i)+skip(i)-1)/skip(i)
else
zstV(i) = zstart(i)/skip(i)
if (mod(zstart(i),skip(i))/=0) zstV(i)=zstV(i)+1
zenV(i) = zend(i)/skip(i)
end if
zszV(i) = zenV(i)-zstV(i)+1
end do
return
end subroutine init_coarser_mesh_statV
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Coarser mesh support for probe
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine init_coarser_mesh_statP(i_skip,j_skip,k_skip,from1)
implicit none
integer, intent(IN) :: i_skip,j_skip,k_skip
logical, intent(IN) :: from1 ! .true. - save 1,n+1,2n+1...
! .false. - save n,2n,3n...
integer, dimension(3) :: skip
integer :: i
coarse_mesh_starts_from_1 = from1
iskipP = i_skip
jskipP = j_skip
kskipP = k_skip
skip(1)=iskipP
skip(2)=jskipP
skip(3)=kskipP
do i=1,3
if (from1) then
xstP(i) = (xstart(i)+skip(i)-1)/skip(i)
if (mod(xstart(i)+skip(i)-1,skip(i))/=0) xstP(i)=xstP(i)+1
xenP(i) = (xend(i)+skip(i)-1)/skip(i)
else
xstP(i) = xstart(i)/skip(i)
if (mod(xstart(i),skip(i))/=0) xstP(i)=xstP(i)+1
xenP(i) = xend(i)/skip(i)
end if
xszP(i) = xenP(i)-xstP(i)+1
end do
do i=1,3
if (from1) then
ystP(i) = (ystart(i)+skip(i)-1)/skip(i)
if (mod(ystart(i)+skip(i)-1,skip(i))/=0) ystP(i)=ystP(i)+1
yenP(i) = (yend(i)+skip(i)-1)/skip(i)
else
ystP(i) = ystart(i)/skip(i)
if (mod(ystart(i),skip(i))/=0) ystP(i)=ystP(i)+1
yenP(i) = yend(i)/skip(i)
end if
yszP(i) = yenP(i)-ystP(i)+1
end do
do i=1,3
if (from1) then
zstP(i) = (zstart(i)+skip(i)-1)/skip(i)
if (mod(zstart(i)+skip(i)-1,skip(i))/=0) zstP(i)=zstP(i)+1
zenP(i) = (zend(i)+skip(i)-1)/skip(i)
else
zstP(i) = zstart(i)/skip(i)
if (mod(zstart(i),skip(i))/=0) zstP(i)=zstP(i)+1
zenP(i) = zend(i)/skip(i)
end if
zszP(i) = zenP(i)-zstP(i)+1
end do
return
end subroutine init_coarser_mesh_statP
! Copy data from a fine-resolution array to a coarse one for statistic
subroutine fine_to_coarseS(ipencil,var_fine,var_coarse)
implicit none
real(mytype), dimension(:,:,:) :: var_fine
real(mytype), dimension(:,:,:) :: var_coarse
integer, intent(IN) :: ipencil
real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
integer :: i,j,k
if (ipencil==1) then
allocate(wk(xstS(1):xenS(1),xstS(2):xenS(2),xstS(3):xenS(3)))
allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=xstS(3),xenS(3)
do j=xstS(2),xenS(2)
do i=xstS(1),xenS(1)
wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
end do
end do
end do
else
do k=xstS(3),xenS(3)
do j=xstS(2),xenS(2)
do i=xstS(1),xenS(1)
wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==2) then
allocate(wk(ystS(1):yenS(1),ystS(2):yenS(2),ystS(3):yenS(3)))
allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=ystS(3),yenS(3)
do j=ystS(2),yenS(2)
do i=ystS(1),yenS(1)
wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
end do
end do
end do
else
do k=ystS(3),yenS(3)
do j=ystS(2),yenS(2)
do i=ystS(1),yenS(1)
wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==3) then
allocate(wk(zstS(1):zenS(1),zstS(2):zenS(2),zstS(3):zenS(3)))
allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=zstS(3),zenS(3)
do j=zstS(2),zenS(2)
do i=zstS(1),zenS(1)
wk(i,j,k) = wk2((i-1)*iskipS+1,(j-1)*jskipS+1,(k-1)*kskipS+1)
end do
end do
end do
else
do k=zstS(3),zenS(3)
do j=zstS(2),zenS(2)
do i=zstS(1),zenS(1)
wk(i,j,k) = wk2(i*iskipS,j*jskipS,k*kskipS)
end do
end do
end do
end if
var_coarse=wk
end if
deallocate(wk,wk2)
return
end subroutine fine_to_coarseS
! Copy data from a fine-resolution array to a coarse one for visualization
subroutine fine_to_coarseV(ipencil,var_fine,var_coarse)
implicit none
real(mytype), dimension(:,:,:) :: var_fine
real(mytype), dimension(:,:,:) :: var_coarse
integer, intent(IN) :: ipencil
real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
integer :: i,j,k
if (ipencil==1) then
allocate(wk(xstV(1):xenV(1),xstV(2):xenV(2),xstV(3):xenV(3)))
allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=xstV(3),xenV(3)
do j=xstV(2),xenV(2)
do i=xstV(1),xenV(1)
wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
end do
end do
end do
else
do k=xstV(3),xenV(3)
do j=xstV(2),xenV(2)
do i=xstV(1),xenV(1)
wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==2) then
allocate(wk(ystV(1):yenV(1),ystV(2):yenV(2),ystV(3):yenV(3)))
allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=ystV(3),yenV(3)
do j=ystV(2),yenV(2)
do i=ystV(1),yenV(1)
wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
end do
end do
end do
else
do k=ystV(3),yenV(3)
do j=ystV(2),yenV(2)
do i=ystV(1),yenV(1)
wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==3) then
allocate(wk(zstV(1):zenV(1),zstV(2):zenV(2),zstV(3):zenV(3)))
allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=zstV(3),zenV(3)
do j=zstV(2),zenV(2)
do i=zstV(1),zenV(1)
wk(i,j,k) = wk2((i-1)*iskipV+1,(j-1)*jskipV+1,(k-1)*kskipV+1)
end do
end do
end do
else
do k=zstV(3),zenV(3)
do j=zstV(2),zenV(2)
do i=zstV(1),zenV(1)
wk(i,j,k) = wk2(i*iskipV,j*jskipV,k*kskipV)
end do
end do
end do
end if
var_coarse=wk
end if
deallocate(wk,wk2)
return
end subroutine fine_to_coarseV
! Copy data from a fine-resolution array to a coarse one for probe
subroutine fine_to_coarseP(ipencil,var_fine,var_coarse)
implicit none
real(mytype), dimension(:,:,:) :: var_fine
real(mytype), dimension(:,:,:) :: var_coarse
integer, intent(IN) :: ipencil
real(mytype), allocatable, dimension(:,:,:) :: wk, wk2
integer :: i,j,k
if (ipencil==1) then
allocate(wk(xstP(1):xenP(1),xstP(2):xenP(2),xstP(3):xenP(3)))
allocate(wk2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=xstP(3),xenP(3)
do j=xstP(2),xenP(2)
do i=xstP(1),xenP(1)
wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
end do
end do
end do
else
do k=xstP(3),xenP(3)
do j=xstP(2),xenP(2)
do i=xstP(1),xenP(1)
wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==2) then
allocate(wk(ystP(1):yenP(1),ystP(2):yenP(2),ystP(3):yenP(3)))
allocate(wk2(ystart(1):yend(1),ystart(2):yend(2),ystart(3):yend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=ystP(3),yenP(3)
do j=ystP(2),yenP(2)
do i=ystP(1),yenP(1)
wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
end do
end do
end do
else
do k=ystP(3),yenP(3)
do j=ystP(2),yenP(2)
do i=ystP(1),yenP(1)
wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
end do
end do
end do
end if
var_coarse=wk
else if (ipencil==3) then
allocate(wk(zstP(1):zenP(1),zstP(2):zenP(2),zstP(3):zenP(3)))
allocate(wk2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
wk2=var_fine
if (coarse_mesh_starts_from_1) then
do k=zstP(3),zenP(3)
do j=zstP(2),zenP(2)
do i=zstP(1),zenP(1)
wk(i,j,k) = wk2((i-1)*iskipP+1,(j-1)*jskipP+1,(k-1)*kskipP+1)
end do
end do
end do
else
do k=zstP(3),zenP(3)
do j=zstP(2),zenP(2)
do i=zstP(1),zenP(1)
wk(i,j,k) = wk2(i*iskipP,j*jskipP,k*kskipP)
end do
end do
end do
end if
var_coarse=wk
end if
deallocate(wk,wk2)
return
end subroutine fine_to_coarseP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Find sub-domain information held by current processor
! INPUT:
! nx, ny, nz - global data dimension
! pdim(3) - number of processor grid in each dimension,
! valid values: 1 - distibute locally;
! 2 - distribute across p_row;
! 3 - distribute across p_col
! OUTPUT:
! lstart(3) - starting index
! lend(3) - ending index
! lsize(3) - size of the sub-block (redundant)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine partition(nx, ny, nz, pdim, lstart, lend, lsize)
implicit none
integer, intent(IN) :: nx, ny, nz
integer, dimension(3), intent(IN) :: pdim
integer, dimension(3), intent(OUT) :: lstart, lend, lsize
integer, allocatable, dimension(:) :: st,en,sz
integer :: i, gsize
do i = 1, 3
if (i==1) then
gsize = nx
else if (i==2) then
gsize = ny
else if (i==3) then
gsize = nz
end if
if (pdim(i) == 1) then ! all local
lstart(i) = 1
lend(i) = gsize
lsize(i) = gsize
elseif (pdim(i) == 2) then ! distribute across dims(1)
allocate(st(0:dims(1)-1))
allocate(en(0:dims(1)-1))
allocate(sz(0:dims(1)-1))
call distribute(gsize,dims(1),st,en,sz)
lstart(i) = st(coord(1))
lend(i) = en(coord(1))
lsize(i) = sz(coord(1))
deallocate(st,en,sz)
elseif (pdim(i) == 3) then ! distribute across dims(2)
allocate(st(0:dims(2)-1))
allocate(en(0:dims(2)-1))
allocate(sz(0:dims(2)-1))
call distribute(gsize,dims(2),st,en,sz)
lstart(i) = st(coord(2))
lend(i) = en(coord(2))
lsize(i) = sz(coord(2))
deallocate(st,en,sz)
end if
end do
return
end subroutine partition
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! - distibutes grid points in one dimension
! - handles uneven distribution properly
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine distribute(data1,proc,st,en,sz)
implicit none
! data1 -- data size in any dimension to be partitioned
! proc -- number of processors in that dimension
! st -- array of starting index
! en -- array of ending index
! sz -- array of local size (redundent)
integer data1,proc,st(0:proc-1),en(0:proc-1),sz(0:proc-1)
integer i,size1,nl,nu
size1=data1/proc
nu = data1 - size1 * proc
nl = proc - nu
st(0) = 1
sz(0) = size1
en(0) = size1
do i=1,nl-1
st(i) = st(i-1) + size1
sz(i) = size1
en(i) = en(i-1) + size1
end do
size1 = size1 + 1
do i=nl,proc-1
st(i) = en(i-1) + 1
sz(i) = size1
en(i) = en(i-1) + size1
end do
en(proc-1)= data1
sz(proc-1)= data1-st(proc-1)+1
return
end subroutine distribute
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Define how each dimension is distributed across processors
! e.g. 17 meshes across 4 processor would be distibuted as (4,4,4,5)
! such global information is required locally at MPI_ALLTOALLV time
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine get_dist(nx,ny,nz,decomp)
integer, intent(IN) :: nx, ny, nz
TYPE(DECOMP_INFO), intent(INOUT) :: decomp
integer, allocatable, dimension(:) :: st,en
allocate(st(0:dims(1)-1))
allocate(en(0:dims(1)-1))
call distribute(nx,dims(1),st,en,decomp%x1dist)
call distribute(ny,dims(1),st,en,decomp%y1dist)
deallocate(st,en)
allocate(st(0:dims(2)-1))
allocate(en(0:dims(2)-1))
call distribute(ny,dims(2),st,en,decomp%y2dist)
call distribute(nz,dims(2),st,en,decomp%z2dist)
deallocate(st,en)
return
end subroutine get_dist
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Prepare the send / receive buffers for MPI_ALLTOALLV communications
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine prepare_buffer(decomp)
implicit none
TYPE(DECOMP_INFO), intent(INOUT) :: decomp
integer :: i
! MPI_ALLTOALLV buffer information
do i=0, dims(1)-1
decomp%x1cnts(i) = decomp%x1dist(i)*decomp%xsz(2)*decomp%xsz(3)
decomp%y1cnts(i) = decomp%ysz(1)*decomp%y1dist(i)*decomp%ysz(3)
if (i==0) then
decomp%x1disp(i) = 0 ! displacement is 0-based index
decomp%y1disp(i) = 0
else
decomp%x1disp(i) = decomp%x1disp(i-1) + decomp%x1cnts(i-1)
decomp%y1disp(i) = decomp%y1disp(i-1) + decomp%y1cnts(i-1)
end if
end do
do i=0, dims(2)-1
decomp%y2cnts(i) = decomp%ysz(1)*decomp%y2dist(i)*decomp%ysz(3)
decomp%z2cnts(i) = decomp%zsz(1)*decomp%zsz(2)*decomp%z2dist(i)
if (i==0) then
decomp%y2disp(i) = 0 ! displacement is 0-based index
decomp%z2disp(i) = 0
else
decomp%y2disp(i) = decomp%y2disp(i-1) + decomp%y2cnts(i-1)
decomp%z2disp(i) = decomp%z2disp(i-1) + decomp%z2cnts(i-1)
end if
end do
! MPI_ALLTOALL buffer information
! For evenly distributed data, following is an easier implementation.
! But it should be covered by the more general formulation below.
!decomp%x1count = decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)/dims(1)
!decomp%y1count = decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3)/dims(1)
!decomp%y2count = decomp%ysz(1)*decomp%ysz(2)*decomp%ysz(3)/dims(2)
!decomp%z2count = decomp%zsz(1)*decomp%zsz(2)*decomp%zsz(3)/dims(2)
! For unevenly distributed data, pad smaller messages. Note the
! last blocks along pencils always get assigned more mesh points
! for X <=> Y transposes
decomp%x1count = decomp%x1dist(dims(1)-1) * &
decomp%y1dist(dims(1)-1) * decomp%xsz(3)
decomp%y1count = decomp%x1count
! for Y <=> Z transposes
decomp%y2count = decomp%y2dist(dims(2)-1) * &
decomp%z2dist(dims(2)-1) * decomp%zsz(1)
decomp%z2count = decomp%y2count
return
end subroutine prepare_buffer
#ifdef SHM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generate shared-memory information
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_info_init_shm(decomp)
implicit none
TYPE(DECOMP_INFO), intent(INOUT) :: decomp
! a copy of old displacement array (will be overwritten by shm code)
allocate(decomp%x1disp_o(0:dims(1)-1),decomp%y1disp_o(0:dims(1)-1), &
decomp%y2disp_o(0:dims(2)-1),decomp%z2disp_o(0:dims(2)-1))
decomp%x1disp_o = decomp%x1disp
decomp%y1disp_o = decomp%y1disp
decomp%y2disp_o = decomp%y2disp
decomp%z2disp_o = decomp%z2disp
call prepare_shared_buffer(decomp%ROW_INFO,DECOMP_2D_COMM_ROW,decomp)
call prepare_shared_buffer(decomp%COL_INFO,DECOMP_2D_COMM_COL,decomp)
return
end subroutine decomp_info_init_shm
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! For shared-memory implementation, prepare send/recv shared buffer
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine prepare_shared_buffer(C,MPI_COMM,decomp)
implicit none
TYPE(SMP_INFO) :: C
INTEGER :: MPI_COMM
TYPE(DECOMP_INFO) :: decomp
INTEGER, ALLOCATABLE :: KTBL(:,:),NARY(:,:),KTBLALL(:,:)
INTEGER MYSMP, MYCORE, COLOR
integer :: ierror
C%MPI_COMM = MPI_COMM
CALL MPI_COMM_SIZE(MPI_COMM,C%NCPU,ierror)
CALL MPI_COMM_RANK(MPI_COMM,C%NODE_ME,ierror)
C%SMP_COMM = MPI_COMM_NULL
C%CORE_COMM = MPI_COMM_NULL
C%SMP_ME= 0
C%NCORE = 0
C%CORE_ME = 0
C%MAXCORE = 0
C%NSMP = 0
C%N_SND = 0
C%N_RCV = 0
C%SND_P = 0
C%RCV_P = 0
C%SND_P_c = 0
C%RCV_P_c = 0
! get smp-node map for this communicator and set up smp communicators
CALL GET_SMP_MAP(C%MPI_COMM, C%NSMP, MYSMP, &
C%NCORE, MYCORE, C%MAXCORE)
C%SMP_ME = MYSMP + 1
C%CORE_ME = MYCORE + 1
! - set up inter/intra smp-node communicators
COLOR = MYCORE
IF (COLOR.GT.0) COLOR = MPI_UNDEFINED
CALL MPI_Comm_split(C%MPI_COMM, COLOR, MYSMP, C%SMP_COMM, ierror)
CALL MPI_Comm_split(C%MPI_COMM, MYSMP, MYCORE, C%CORE_COMM, ierror)
! - allocate work space
ALLOCATE(KTBL(C%MAXCORE,C%NSMP),NARY(C%NCPU,C%NCORE))
ALLOCATE(KTBLALL(C%MAXCORE,C%NSMP))
! - set up smp-node/core to node_me lookup table
KTBL = 0
KTBL(C%CORE_ME,C%SMP_ME) = C%NODE_ME + 1
CALL MPI_ALLREDUCE(KTBL,KTBLALL,C%NSMP*C%MAXCORE,MPI_INTEGER, &
MPI_SUM,MPI_COMM,ierror)
KTBL=KTBLALL
! IF (SUM(KTBL) /= C%NCPU*(C%NCPU+1)/2) &
! CALL MPI_ABORT(...
! compute offsets in shared SNDBUF and RCVBUF
CALL MAPSET_SMPSHM(C, KTBL, NARY, decomp)
DEALLOCATE(KTBL,NARY)
return
end subroutine prepare_shared_buffer
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Use Ian Bush's FreeIPC to generate shared-memory information
! - system independent solution
! - replacing David Tanqueray's implementation in alloc_shm.c
! (old C code renamed to get_smp_map2)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine get_smp_map(comm, nnodes, my_node, ncores, my_core, maxcor)
use FIPC_module
implicit none
integer, intent(IN) :: comm
integer, intent(OUT) :: nnodes, my_node, ncores, my_core, maxcor
integer :: intra_comm, extra_comm
integer :: ierror
call FIPC_init(comm, ierror)
! intra_comm: communicator for processes on this shared memory node
! extra_comm: communicator for all rank 0 on each shared memory node
call FIPC_ctxt_intra_comm(FIPC_ctxt_world, intra_comm, ierror)
call FIPC_ctxt_extra_comm(FIPC_ctxt_world, extra_comm, ierror)
call MPI_COMM_SIZE(intra_comm, ncores, ierror)
call MPI_COMM_RANK(intra_comm, my_core, ierror)
! only rank 0 on each shared memory node member of extra_comm
! for others extra_comm = MPI_COMM_NULL
if (extra_comm /= MPI_COMM_NULL) then
call MPI_COMM_SIZE(extra_comm, nnodes, ierror)
call MPI_COMM_RANK(extra_comm, my_node, ierror)
end if
! other ranks share the same information as their leaders
call MPI_BCAST( nnodes, 1, MPI_INTEGER, 0, intra_comm, ierror)
call MPI_BCAST(my_node, 1, MPI_INTEGER, 0, intra_comm, ierror)
! maxcor
call MPI_ALLREDUCE(ncores, maxcor, 1, MPI_INTEGER, MPI_MAX, &
MPI_COMM_WORLD, ierror)
call FIPC_finalize(ierror)
return
end subroutine get_smp_map
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Set up smp-node based shared memory maps
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE MAPSET_SMPSHM(C, KTBL, NARY, decomp)
IMPLICIT NONE
TYPE (SMP_INFO) C
INTEGER KTBL(C%MAXCORE,C%NSMP)
INTEGER NARY(C%NCPU,C%NCORE)
TYPE (DECOMP_INFO) :: decomp
INTEGER i, j, k, l, N, PTR, BSIZ, ierror, status, seed
character*16 s
BSIZ = C%N_SND
! a - SNDBUF
IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
ALLOCATE(decomp%x1cnts_s(C%NSMP),decomp%x1disp_s(C%NSMP+1), &
stat=status)
CALL MPI_Allgather(decomp%x1cnts, C%NCPU, MPI_INTEGER, &
NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
PTR = 0
DO i=1,C%NSMP
decomp%x1disp_s(i) = PTR
N = 0
DO j=1,C%MAXCORE
k = KTBL(j,i)
IF (k > 0) then
DO l=1,C%NCORE
IF (l == C%CORE_ME) decomp%x1disp_o(k-1) = PTR
N = N + NARY(k,l)
PTR = PTR + NARY(k,l)
END DO
END IF
END DO
decomp%x1cnts_s(i) = N
END DO
decomp%x1disp_s(C%NSMP+1) = PTR
IF (PTR > BSIZ) BSIZ = PTR
ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
ALLOCATE(decomp%y2cnts_s(C%NSMP),decomp%y2disp_s(C%NSMP+1), &
stat=status)
CALL MPI_Allgather(decomp%y2cnts, C%NCPU, MPI_INTEGER, &
NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
PTR = 0
DO i=1,C%NSMP
decomp%y2disp_s(i) = PTR
N = 0
DO j=1,C%MAXCORE
k = KTBL(j,i)
IF (k > 0) then
DO l=1,C%NCORE
IF (l == C%CORE_ME) decomp%y2disp_o(k-1) = PTR
N = N + NARY(k,l)
PTR = PTR + NARY(k,l)
END DO
END IF
END DO
decomp%y2cnts_s(i) = N
END DO
decomp%y2disp_s(C%NSMP+1) = PTR
IF (PTR > BSIZ) BSIZ = PTR
END IF
! b - RCVBUF
IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
ALLOCATE(decomp%y1cnts_s(C%NSMP),decomp%y1disp_s(C%NSMP+1), &
stat=status)
CALL MPI_Allgather(decomp%y1cnts, C%NCPU, MPI_INTEGER, &
NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
PTR = 0
DO i=1,C%NSMP
decomp%y1disp_s(i) = PTR
N=0
DO j=1,C%NCORE
DO l=1,C%MAXCORE
k = KTBL(l,i)
IF (k > 0) then
IF (j == C%CORE_ME) decomp%y1disp_o(k-1) = PTR
N = N + NARY(k,j)
PTR = PTR + NARY(k,j)
END IF
END DO
END DO
decomp%y1cnts_s(i) = N
END DO
decomp%y1disp_s(C%NSMP+1) = PTR
IF (PTR > BSIZ) BSIZ = PTR
ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
ALLOCATE(decomp%z2cnts_s(C%NSMP),decomp%z2disp_s(C%NSMP+1), &
stat=status)
CALL MPI_Allgather(decomp%z2cnts, C%NCPU, MPI_INTEGER, &
NARY, C%NCPU, MPI_INTEGER, C%CORE_COMM, ierror)
PTR = 0
DO i=1,C%NSMP
decomp%z2disp_s(i) = PTR
N=0
DO j=1,C%NCORE
DO l=1,C%MAXCORE
k = KTBL(l,i)
IF (k > 0) then
IF (j == C%CORE_ME) decomp%z2disp_o(k-1) = PTR
N = N + NARY(k,j)
PTR = PTR + NARY(k,j)
END IF
END DO
END DO
decomp%z2cnts_s(i) = N
END DO
decomp%z2disp_s(C%NSMP+1) = PTR
IF (PTR > BSIZ) BSIZ = PTR
END IF
! check buffer size and (re)-allocate buffer space if necessary
IF (BSIZ > C%N_SND) then
IF (C%SND_P /= 0) CALL DEALLOC_SHM(C%SND_P, C%CORE_COMM)
! make sure each rank has unique keys to get shared memory
!IF (C%MPI_COMM==DECOMP_2D_COMM_COL) THEN
! seed = nrank+nproc*0+1 ! has to be non-zero
!ELSE IF (C%MPI_COMM==DECOMP_2D_COMM_ROW) THEN
! seed = nrank+nproc*1+1
!END IF
status = 1
!CALL ALLOC_SHM(C%SND_P, BSIZ, real_type, C%CORE_COMM, status, &
! seed)
CALL ALLOC_SHM(C%SND_P, BSIZ, real_type, C%CORE_COMM, status)
C%N_SND = BSIZ
IF (C%RCV_P /= 0) CALL DEALLOC_SHM(C%RCV_P, C%CORE_COMM)
status = 1
CALL ALLOC_SHM(C%RCV_P, BSIZ, real_type, C%CORE_COMM, status)
C%N_RCV = BSIZ
IF (C%SND_P_c /= 0) CALL DEALLOC_SHM(C%SND_P_c, C%CORE_COMM)
status = 1
CALL ALLOC_SHM(C%SND_P_c, BSIZ, complex_type, C%CORE_COMM, status)
C%N_SND = BSIZ
IF (C%RCV_P_c /= 0) CALL DEALLOC_SHM(C%RCV_P_c, C%CORE_COMM)
status = 1
CALL ALLOC_SHM(C%RCV_P_c, BSIZ, complex_type, C%CORE_COMM, status)
C%N_RCV = BSIZ
END IF
RETURN
END SUBROUTINE MAPSET_SMPSHM
#endif
#ifdef OCC
! For non-blocking communication code, progress the comminication stack
subroutine transpose_test(handle)
implicit none
integer :: handle, ierror
call NBC_TEST(handle,ierror)
return
end subroutine transpose_test
#endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Transposition routines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "transpose_x_to_y.f90"
#include "transpose_y_to_z.f90"
#include "transpose_z_to_y.f90"
#include "transpose_y_to_x.f90"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Auto-tuning algorithm to select the best 2D processor grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine best_2d_grid(iproc, best_p_row, best_p_col)
implicit none
integer, intent(IN) :: iproc
integer, intent(OUT) :: best_p_row, best_p_col
integer, allocatable, dimension(:) :: factors
double precision :: t1, t2, best_time
integer :: nfact, i, row, col, ierror, errorcode
real(mytype), allocatable, dimension(:,:,:) :: u1, u2, u3
TYPE(DECOMP_INFO) :: decomp
if (nrank==0) write(*,*) 'In auto-tuning mode......'
best_time = huge(t1)
best_p_row = -1
best_p_col = -1
i = int(sqrt(real(iproc))) + 10 ! enough space to save all factors
allocate(factors(i))
call findfactor(iproc, factors, nfact)
if (nrank==0) write(*,*) 'factors: ', (factors(i), i=1,nfact)
do i=1, nfact
row = factors(i)
col = iproc / row
! enforce the limitation of 2D decomposition
if (min(nx_global,ny_global)>=row .and. &
min(ny_global,nz_global)>=col) then
! 2D Catersian topology
dims(1) = row
dims(2) = col
periodic(1) = .false.
periodic(2) = .false.
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false.,DECOMP_2D_COMM_CART_X, ierror)
call MPI_CART_COORDS(DECOMP_2D_COMM_CART_X,nrank,2,coord,ierror)
! communicators defining sub-groups for ALLTOALL(V)
call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.true.,.false./), &
DECOMP_2D_COMM_COL,ierror)
call MPI_CART_SUB(DECOMP_2D_COMM_CART_X,(/.false.,.true./), &
DECOMP_2D_COMM_ROW,ierror)
! generate 2D decomposition information for this row*col
call decomp_info_init(nx_global,ny_global,nz_global,decomp)
! arrays for X,Y and Z-pencils
allocate(u1(decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)))
allocate(u2(decomp%ysz(1),decomp%ysz(2),decomp%ysz(3)))
allocate(u3(decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)))
! timing the transposition routines
t1 = MPI_WTIME()
call transpose_x_to_y(u1,u2,decomp)
call transpose_y_to_z(u2,u3,decomp)
call transpose_z_to_y(u3,u2,decomp)
call transpose_y_to_x(u2,u1,decomp)
t2 = MPI_WTIME() - t1
deallocate(u1,u2,u3)
call decomp_info_finalize(decomp)
call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
MPI_COMM_WORLD,ierror)
t1 = t1 / dble(nproc)
if (nrank==0) then
write(*,*) 'processor grid', row, ' by ', col, ' time=', t1
end if
if (best_time > t1) then
best_time = t1
best_p_row = row
best_p_col = col
end if
end if
end do ! loop through processer grid
deallocate(factors)
if (best_p_row/=-1) then
if (nrank==0) then
write(*,*) 'the best processor grid is probably ', &
best_p_row, ' by ', best_p_col
end if
else
errorcode = 9
call decomp_2d_abort(errorcode, &
'The processor-grid auto-tuning code failed. ' // &
'The number of processes requested is probably too large.')
end if
return
end subroutine best_2d_grid
#include "factor.f90"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Halo cell support
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "halo.f90"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Error handling
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_2d_abort(errorcode, msg)
implicit none
integer, intent(IN) :: errorcode
character(len=*), intent(IN) :: msg
integer :: ierror
if (nrank==0) then
write(*,*) '2DECOMP&FFT ERROR - errorcode: ', errorcode
write(*,*) 'ERROR MESSAGE: ' // msg
end if
call MPI_ABORT(MPI_COMM_WORLD,errorcode,ierror)
return
end subroutine decomp_2d_abort
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Utility routines to help allocate 3D arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#include "alloc.f90"
end module decomp_2d
derive.f90 0000644 0001750 0001750 00000247123 13051023554 012573 0 ustar slaizet slaizet !################################################################################
!This file is part of Incompact3d.
!
!Incompact3d
!Copyright (c) 2012 Eric Lamballais and Sylvain Laizet
!eric.lamballais@univ-poitiers.fr / sylvain.laizet@gmail.com
!
! Incompact3d 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.
!
! Incompact3d 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 the code. If not, see .
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
! We kindly request that you cite Incompact3d in your publications and
! presentations. The following citations are suggested:
!
! 1-Laizet S. & Lamballais E., 2009, High-order compact schemes for
! incompressible flows: a simple and efficient method with the quasi-spectral
! accuracy, J. Comp. Phys., vol 228 (15), pp 5989-6015
!
! 2-Laizet S. & Li N., 2011, Incompact3d: a powerful tool to tackle turbulence
! problems with up to 0(10^5) computational cores, Int. J. of Numerical
! Methods in Fluids, vol 67 (11), pp 1735-1757
!################################################################################
!********************************************************************
!
subroutine derx(tx,ux,rx,sx,ffx,fsx,fwx,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tx,ux,rx
real(mytype), dimension(ny,nz):: sx
real(mytype), dimension(nx):: ffx,fsx,fwx
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=afix*(ux(2,j,k)-ux(nx,j,k))&
+bfix*(ux(3,j,k)-ux(nx-1,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=afix*(ux(3,j,k)-ux(1,j,k))&
+bfix*(ux(4,j,k)-ux(nx,j,k))
rx(2,j,k)=0._mytype
do i=3,nx-2
tx(i,j,k)=afix*(ux(i+1,j,k)-ux(i-1,j,k))&
+bfix*(ux(i+2,j,k)-ux(i-2,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-1,j,k)=afix*(ux(nx,j,k)-ux(nx-2,j,k))&
+bfix*(ux(1,j,k)-ux(nx-3,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx,j,k)=afix*(ux(1,j,k)-ux(nx-1,j,k))&
+bfix*(ux(2,j,k)-ux(nx-2,j,k))
rx(nx,j,k)=alfaix
do i=2, nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*fsx(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*fsx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*fwx(nx)
rx(nx,j,k)=rx(nx,j,k)*fwx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-ffx(i)*tx(i+1,j,k))*fwx(i)
rx(i,j,k)=(rx(i,j,k)-ffx(i)*rx(i+1,j,k))*fwx(i)
enddo
sx(j,k)=(tx(1,j,k)-alfaix*tx(nx,j,k))&
/(1._mytype+rx(1,j,k)-alfaix*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if (nclx==1) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=0._mytype
tx(2,j,k)=afix*(ux(3,j,k)-ux(1,j,k))&
+bfix*(ux(4,j,k)-ux(2,j,k))
do i=3,nx-2
tx(i,j,k)=afix*(ux(i+1,j,k)-ux(i-1,j,k))&
+bfix*(ux(i+2,j,k)-ux(i-2,j,k))
enddo
tx(nx-1,j,k)=afix*(ux(nx,j,k)-ux(nx-2,j,k))&
+bfix*(ux(nx-1,j,k)-ux(nx-3,j,k))
tx(nx,j,k)=0._mytype
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*fsx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*fwx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-ffx(i)*tx(i+1,j,k))*fwx(i)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=afix*(ux(2,j,k)+ux(2,j,k))&
+bfix*(ux(3,j,k)+ux(3,j,k))
tx(2,j,k)=afix*(ux(3,j,k)-ux(1,j,k))&
+bfix*(ux(4,j,k)+ux(2,j,k))
do i=3,nx-2
tx(i,j,k)=afix*(ux(i+1,j,k)-ux(i-1,j,k))&
+bfix*(ux(i+2,j,k)-ux(i-2,j,k))
enddo
tx(nx-1,j,k)=afix*(ux(nx,j,k)-ux(nx-2,j,k))&
+bfix*((-ux(nx-1,j,k))-ux(nx-3,j,k))
tx(nx,j,k)=afix*((-ux(nx-1,j,k))-ux(nx-1,j,k))&
+bfix*((-ux(nx-2,j,k))-ux(nx-2,j,k))
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*fsx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*fwx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-ffx(i)*tx(i+1,j,k))*fwx(i)
enddo
enddo
enddo
endif
endif
if (nclx==2) then
do k=1,nz
do j=1,ny
tx(1,j,k)=af1x*ux(1,j,k)+bf1x*ux(2,j,k)+cf1x*ux(3,j,k)
tx(2,j,k)=af2x*(ux(3,j,k)-ux(1,j,k))
do i=3,nx-2
tx(i,j,k)=afix*(ux(i+1,j,k)-ux(i-1,j,k))&
+bfix*(ux(i+2,j,k)-ux(i-2,j,k))
enddo
tx(nx-1,j,k)=afmx*(ux(nx,j,k)-ux(nx-2,j,k))
tx(nx,j,k)=(-afnx*ux(nx,j,k))-bfnx*ux(nx-1,j,k)-cfnx*ux(nx-2,j,k)
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*fsx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*fwx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-ffx(i)*tx(i+1,j,k))*fwx(i)
enddo
enddo
enddo
endif
return
end subroutine derx
!********************************************************************
!
subroutine dery(ty,uy,ry,sy,ffy,fsy,fwy,ppy,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nz,i,j,k,npaire
real(mytype), dimension(nx,ny,nz) :: ty,uy
real(mytype), dimension(nx,ny,nz) :: ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(ny) :: ffy,fsy,fwy,ppy
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=afjy*(uy(i,2,k)-uy(i,ny,k))&
+bfjy*(uy(i,3,k)-uy(i,ny-1,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=afjy*(uy(i,3,k)-uy(i,1,k))&
+bfjy*(uy(i,4,k)-uy(i,ny,k))
ry(i,2,k)=0._mytype
enddo
enddo
do k=1,nz
do j=3,ny-2
do i=1,nx
ty(i,j,k)=afjy*(uy(i,j+1,k)-uy(i,j-1,k))&
+bfjy*(uy(i,j+2,k)-uy(i,j-2,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=afjy*(uy(i,ny,k)-uy(i,ny-2,k))&
+bfjy*(uy(i,1,k)-uy(i,ny-3,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny,k)=afjy*(uy(i,1,k)-uy(i,ny-1,k))&
+bfjy*(uy(i,2,k)-uy(i,ny-2,k))
ry(i,ny,k)=alfajy
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*fsy(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*fsy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fwy(ny)
ry(i,ny,k)=ry(i,ny,k)*fwy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-ffy(j)*ty(i,j+1,k))*fwy(j)
ry(i,j,k)=(ry(i,j,k)-ffy(j)*ry(i,j+1,k))*fwy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=(ty(i,1,k)-alfajy*ty(i,ny,k))&
/(1._mytype+ry(i,1,k)-alfajy*ry(i,ny,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if (ncly==1) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=0._mytype
ty(i,2,k)=afjy*(uy(i,3,k)-uy(i,1,k))&
+bfjy*(uy(i,4,k)-uy(i,2,k))
enddo
enddo
do k=1,nz
do j=3,ny-2
do i=1,nx
ty(i,j,k)=afjy*(uy(i,j+1,k)-uy(i,j-1,k))&
+bfjy*(uy(i,j+2,k)-uy(i,j-2,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=afjy*(uy(i,ny,k)-uy(i,ny-2,k))&
+bfjy*(uy(i,ny-1,k)-uy(i,ny-3,k))
ty(i,ny,k)=0._mytype
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*fsy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fwy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-ffy(j)*ty(i,j+1,k))*fwy(j)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=afjy*(uy(i,2,k)+uy(i,2,k))&
+bfjy*(uy(i,3,k)+uy(i,3,k))
ty(i,2,k)=afjy*(uy(i,3,k)-uy(i,1,k))&
+bfjy*(uy(i,4,k)+uy(i,2,k))
enddo
enddo
do k=1,nz
do j=3,ny-2
do i=1,nx
ty(i,j,k)=afjy*(uy(i,j+1,k)-uy(i,j-1,k))&
+bfjy*(uy(i,j+2,k)-uy(i,j-2,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=afjy*(uy(i,ny,k)-uy(i,ny-2,k))&
+bfjy*((-uy(i,ny-1,k))-uy(i,ny-3,k))
ty(i,ny,k)=afjy*((-uy(i,ny-1,k))-uy(i,ny-1,k))&
+bfjy*((-uy(i,ny-2,k))-uy(i,ny-2,k))
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*fsy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fwy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-ffy(j)*ty(i,j+1,k))*fwy(j)
enddo
enddo
enddo
endif
endif
if (ncly==2) then
do k=1,nz
do i=1,nx
ty(i,1,k)=af1y*uy(i,1,k)+bf1y*uy(i,2,k)+cf1y*uy(i,3,k)
ty(i,2,k)=af2y*(uy(i,3,k)-uy(i,1,k))
enddo
enddo
do k=1,nz
do j=3,ny-2
do i=1,nx
ty(i,j,k)=afjy*(uy(i,j+1,k)-uy(i,j-1,k))&
+bfjy*(uy(i,j+2,k)-uy(i,j-2,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=afmy*(uy(i,ny,k)-uy(i,ny-2,k))
ty(i,ny,k)=-afny*uy(i,ny,k)-bfny*uy(i,ny-1,k)-cfny*uy(i,ny-2,k)
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*fsy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fwy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-ffy(j)*ty(i,j+1,k))*fwy(j)
enddo
enddo
enddo
endif
if (istret.ne.0) then
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)*ppy(j)
enddo
enddo
enddo
endif
return
end subroutine dery
!********************************************************************
!
subroutine derz(tz,uz,rz,sz,ffz,fsz,fwz,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tz,uz,rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nz) :: ffz,fsz,fwz
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=afkz*(uz(i,j,2)-uz(i,j,nz ))&
+bfkz*(uz(i,j,3)-uz(i,j,nz-1))
rz(i,j,1)=-1._mytype
tz(i,j,2)=afkz*(uz(i,j,3)-uz(i,j,1 ))&
+bfkz*(uz(i,j,4)-uz(i,j,nz))
rz(i,j,2)=0._mytype
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=afkz*(uz(i,j,k+1)-uz(i,j,k-1))&
+bfkz*(uz(i,j,k+2)-uz(i,j,k-2))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=afkz*(uz(i,j,nz)-uz(i,j,nz-2))&
+bfkz*(uz(i,j,1 )-uz(i,j,nz-3))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz )=afkz*(uz(i,j,1)-uz(i,j,nz-1))&
+bfkz*(uz(i,j,2)-uz(i,j,nz-2))
rz(i,j,nz )=alfakz
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*fsz(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*fsz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fwz(nz)
rz(i,j,nz)=rz(i,j,nz)*fwz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-ffz(k)*tz(i,j,k+1))*fwz(k)
rz(i,j,k)=(rz(i,j,k)-ffz(k)*rz(i,j,k+1))*fwz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=( tz(i,j,1)-alfakz*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-alfakz*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if (nclz==1) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=0._mytype
tz(i,j,2)=afkz*(uz(i,j,3)-uz(i,j,1))&
+bfkz*(uz(i,j,4)-uz(i,j,2))
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=afkz*(uz(i,j,k+1)-uz(i,j,k-1))&
+bfkz*(uz(i,j,k+2)-uz(i,j,k-2))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=afkz*(uz(i,j,nz )-uz(i,j,nz-2))&
+bfkz*(uz(i,j,nz-1)-uz(i,j,nz-3))
tz(i,j,nz )=0._mytype
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*fsz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fwz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-ffz(k)*tz(i,j,k+1))*fwz(k)
enddo
enddo
enddo
endif
if (npaire==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=afkz*(uz(i,j,2)+uz(i,j,2))&
+bfkz*(uz(i,j,3)+uz(i,j,3))
tz(i,j,2)=afkz*(uz(i,j,3)-uz(i,j,1))&
+bfkz*(uz(i,j,4)+uz(i,j,2))
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=afkz*(uz(i,j,k+1)-uz(i,j,k-1))&
+bfkz*(uz(i,j,k+2)-uz(i,j,k-2))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=afkz*( uz(i,j,nz )-uz(i,j,nz-2))&
+bfkz*(-uz(i,j,nz-1)-uz(i,j,nz-3))
tz(i,j,nz )=afkz*(-uz(i,j,nz-1)-uz(i,j,nz-1))&
+bfkz*(-uz(i,j,nz-2)-uz(i,j,nz-2))
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*fsz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fwz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-ffz(k)*tz(i,j,k+1))*fwz(k)
enddo
enddo
enddo
endif
endif
if (nclz==2) then
do j=1,ny
do i=1,nx
tz(i,j,1)=af1z*uz(i,j,1)+bf1z*uz(i,j,2)&
+cf1z*uz(i,j,3)
tz(i,j,2)=af2z*(uz(i,j,3)-uz(i,j,1))
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=afkz*(uz(i,j,k+1)-uz(i,j,k-1))&
+bfkz*(uz(i,j,k+2)-uz(i,j,k-2))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)= afmz*(uz(i,j,nz)-uz(i,j,nz-2))
tz(i,j,nz )=-afnz*uz(i,j,nz)-bfnz*uz(i,j,nz-1)&
-cfnz*uz(i,j,nz-2)
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*fsz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fwz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-ffz(k)*tz(i,j,k+1))*fwz(k)
enddo
enddo
enddo
endif
return
end subroutine derz
!********************************************************************
!
subroutine derxx(tx,ux,rx,sx,sfx,ssx,swx,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tx,ux,rx
real(mytype), dimension(ny,nz) :: sx
real(mytype), dimension(nx):: sfx,ssx,swx
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=asix*(ux(2,j,k)-ux(1 ,j,k)&
-ux(1,j,k)+ux(nx ,j,k))&
+bsix*(ux(3,j,k)-ux(1 ,j,k)&
-ux(1,j,k)+ux(nx-1,j,k))&
+csix*(ux(4,j,k)-ux(1 ,j,k)&
-ux(1,j,k)+ux(nx-2,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=asix*(ux(3,j,k)-ux(2 ,j,k)&
-ux(2,j,k)+ux(1 ,j,k))&
+bsix*(ux(4,j,k)-ux(2 ,j,k)&
-ux(2,j,k)+ux(nx ,j,k))&
+csix*(ux(5,j,k)-ux(2 ,j,k)&
-ux(2,j,k)+ux(nx-1,j,k))
rx(2,j,k)=0._mytype
tx(3,j,k)=asix*(ux(4,j,k)-ux(3 ,j,k)&
-ux(3,j,k)+ux(2 ,j,k))&
+bsix*(ux(5,j,k)-ux(3 ,j,k)&
-ux(3,j,k)+ux(1 ,j,k))&
+csix*(ux(6,j,k)-ux(3 ,j,k)&
-ux(3,j,k)+ux(nx,j,k))
rx(3,j,k)=0._mytype
do i=4,nx-3
tx(i,j,k)=asix*(ux(i+1,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-1,j,k))&
+bsix*(ux(i+2,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-2,j,k))&
+csix*(ux(i+3,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-3,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-2,j,k)=asix*(ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-3,j,k))&
+bsix*(ux(nx ,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-4,j,k))&
+csix*(ux(1 ,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-5,j,k))
rx(nx-2,j,k)=0._mytype
tx(nx-1,j,k)=asix*(ux(nx ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-2,j,k))&
+bsix*(ux(1 ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-3,j,k))&
+csix*(ux(2 ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-4,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx ,j,k)=asix*(ux(1 ,j,k)-ux(nx ,j,k)&
-ux(nx,j,k)+ux(nx-1,j,k))&
+bsix*(ux(2 ,j,k)-ux(nx ,j,k)&
-ux(nx,j,k)+ux(nx-2,j,k))&
+csix*(ux(3 ,j,k)-ux(nx ,j,k)&
-ux(nx,j,k)+ux(nx-3,j,k))
rx(nx ,j,k)=alsaix
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*ssx(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*ssx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*swx(nx)
rx(nx,j,k)=rx(nx,j,k)*swx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-sfx(i)*tx(i+1,j,k))*swx(i)
rx(i,j,k)=(rx(i,j,k)-sfx(i)*rx(i+1,j,k))*swx(i)
enddo
sx(j,k)=( tx(1,j,k)-alsaix*tx(nx,j,k))/&
(1._mytype+rx(1,j,k)-alsaix*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if (nclx==1) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=asix*(ux(2,j,k)-ux(1,j,k)&
-ux(1,j,k)+ux(2,j,k))&
+bsix*(ux(3,j,k)-ux(1,j,k)&
-ux(1,j,k)+ux(3,j,k))&
+csix*(ux(4,j,k)-ux(1,j,k)&
-ux(1,j,k)+ux(4,j,k))
tx(2,j,k)=asix*(ux(3,j,k)-ux(2,j,k)&
-ux(2,j,k)+ux(1,j,k))&
+bsix*(ux(4,j,k)-ux(2,j,k)&
-ux(2,j,k)+ux(2,j,k))&
+csix*(ux(5,j,k)-ux(2,j,k)&
-ux(2,j,k)+ux(3,j,k))
tx(3,j,k)=asix*(ux(4,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(2,j,k))&
+bsix*(ux(5,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(1,j,k))&
+csix*(ux(6,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(2,j,k))
do i=4,nx-3
tx(i,j,k)=asix*(ux(i+1,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-1,j,k))&
+bsix*(ux(i+2,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-2,j,k))&
+csix*(ux(i+3,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-3,j,k))
enddo
tx(nx-2,j,k)=asix*(ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-3,j,k))&
+bsix*(ux(nx ,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-4,j,k))&
+csix*(ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-5,j,k))
tx(nx-1,j,k)=asix*(ux(nx ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-2,j,k))&
+bsix*(ux(nx-1,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-3,j,k))&
+csix*(ux(nx-2,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-4,j,k))
tx(nx ,j,k)=asix*(ux(nx-1,j,k)-ux(nx ,j,k)&
-ux(nx ,j,k)+ux(nx-1,j,k))&
+bsix*(ux(nx-2,j,k)-ux(nx ,j,k)&
-ux(nx ,j,k)+ux(nx-2,j,k))&
+csix*(ux(nx-3,j,k)-ux(nx ,j,k)&
-ux(nx ,j,k)+ux(nx-3,j,k))
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*ssx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*swx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-sfx(i)*tx(i+1,j,k))*swx(i)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=0._mytype
tx(2,j,k)=asix*(ux(3,j,k)-ux(2,j,k)&
-ux(2,j,k)+ux(1,j,k))&
+bsix*(ux(4,j,k)-ux(2,j,k)&
-ux(2,j,k)-ux(2,j,k))&
+csix*(ux(5,j,k)-ux(2,j,k)&
-ux(2,j,k)-ux(3,j,k))
tx(3,j,k)=asix*(ux(4,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(2,j,k))&
+bsix*(ux(5,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(1,j,k))&
+csix*(ux(6,j,k)-ux(3,j,k)&
-ux(3,j,k)-ux(2,j,k))
do i=4,nx-3
tx(i,j,k)=asix*(ux(i+1,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-1,j,k))&
+bsix*(ux(i+2,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-2,j,k))&
+csix*(ux(i+3,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-3,j,k))
enddo
tx(nx-2,j,k)=asix*( ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-3,j,k))&
+bsix*( ux(nx ,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-4,j,k))&
+csix*(-ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-5,j,k))
tx(nx-1,j,k)=asix*( ux(nx ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-2,j,k))&
+bsix*(-ux(nx-1,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-3,j,k))&
+csix*(-ux(nx-2,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-4,j,k))
tx(nx ,j,k)=0._mytype
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*ssx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*swx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-sfx(i)*tx(i+1,j,k))*swx(i)
enddo
enddo
enddo
endif
endif
if (nclx==2) then
do k=1,nz
do j=1,ny
tx(1,j,k)=as1x*ux(1,j,k)+bs1x*ux(2,j,k)&
+cs1x*ux(3,j,k)+ds1x*ux(4,j,k)
tx(2,j,k)=as2x*(ux(3,j,k)-ux(2,j,k)&
-ux(2,j,k)+ux(1,j,k))
tx(3,j,k)=as3x*(ux(4,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(2,j,k))&
+bs3x*(ux(5,j,k)-ux(3,j,k)&
-ux(3,j,k)+ux(1,j,k))
do i=4,nx-3
tx(i,j,k)=asix*(ux(i+1,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-1,j,k))&
+bsix*(ux(i+2,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-2,j,k))&
+csix*(ux(i+3,j,k)-ux(i ,j,k)&
-ux(i ,j,k)+ux(i-3,j,k))
enddo
tx(nx-2,j,k)=astx*(ux(nx-1,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-3,j,k))&
+bstx*(ux(nx ,j,k)-ux(nx-2,j,k)&
-ux(nx-2,j,k)+ux(nx-4,j,k))
tx(nx-1,j,k)=asmx*(ux(nx ,j,k)-ux(nx-1,j,k)&
-ux(nx-1,j,k)+ux(nx-2,j,k))
tx(nx ,j,k)=asnx*ux(nx ,j,k)+bsnx*ux(nx-1,j,k)&
+csnx*ux(nx-2,j,k)+dsnx*ux(nx-3,j,k)
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*ssx(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*swx(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-sfx(i)*tx(i+1,j,k))*swx(i)
enddo
enddo
enddo
endif
return
end subroutine derxx
!********************************************************************
!
subroutine deryy(ty,uy,ry,sy,sfy,ssy,swy,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: ty,uy,ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(ny) :: sfy,ssy,swy
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=asjy*(uy(i,2,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,ny,k))&
+bsjy*(uy(i,3,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,ny-1,k))&
+csjy*(uy(i,4,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,ny-2,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=asjy*(uy(i,3,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,1,k))&
+bsjy*(uy(i,4,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,ny,k))&
+csjy*(uy(i,5,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,ny-1,k))
ry(i,2,k)=0._mytype
ty(i,3,k)=asjy*(uy(i,4,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,2,k))&
+bsjy*(uy(i,5,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,1,k))&
+csjy*(uy(i,6,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,ny,k))
ry(i,3,k)=0._mytype
enddo
enddo
do k=1,nz
do j=4,ny-3
do i=1,nx
ty(i,j,k)=asjy*(uy(i,j+1,k)-uy(i,j,k)&
-uy(i,j,k)+uy(i,j-1,k))&
+bsjy*(uy(i,j+2,k)-uy(i,j,k)&
-uy(i,j,k)+uy(i,j-2,k))&
+csjy*(uy(i,j+3,k)-uy(i,j,k)&
-uy(i,j,k)+uy(i,j-3,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=asjy*(uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-3,k))&
+bsjy*(uy(i,ny ,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-4,k))&
+csjy*(uy(i,1 ,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-5,k))
ry(i,ny-2,k)=0._mytype
ty(i,ny-1,k)=asjy*(uy(i,ny ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-2,k))&
+bsjy*(uy(i,1 ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-3,k))&
+csjy*(uy(i,2 ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-4,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny ,k)=asjy*(uy(i,1 ,k)-uy(i,ny ,k)&
-uy(i,ny,k)+uy(i,ny-1,k))&
+bsjy*(uy(i,2 ,k)-uy(i,ny ,k)&
-uy(i,ny,k)+uy(i,ny-2,k))&
+csjy*(uy(i,3 ,k)-uy(i,ny ,k)&
-uy(i,ny,k)+uy(i,ny-3,k))
ry(i,ny ,k)=alsajy
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*ssy(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*ssy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*swy(ny)
ry(i,ny,k)=ry(i,ny,k)*swy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-sfy(j)*ty(i,j+1,k))*swy(j)
ry(i,j,k)=(ry(i,j,k)-sfy(j)*ry(i,j+1,k))*swy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=( ty(i,1,k)-alsajy*ty(i,ny,k))/&
(1._mytype+ry(i,1,k)-alsajy*ry(i,ny,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if (ncly==1) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=asjy*(uy(i,2,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,2,k))&
+bsjy*(uy(i,3,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,3,k))&
+csjy*(uy(i,4,k)-uy(i,1,k)&
-uy(i,1,k)+uy(i,4,k))
ty(i,2,k)=asjy*(uy(i,3,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,1,k))&
+bsjy*(uy(i,4,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,2,k))&
+csjy*(uy(i,5,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,3,k))
ty(i,3,k)=asjy*(uy(i,4,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,2,k))&
+bsjy*(uy(i,5,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,1,k))&
+csjy*(uy(i,6,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,2,k))
enddo
enddo
do k=1,nz
do j=4,ny-3
do i=1,nx
ty(i,j,k)=asjy*(uy(i,j+1,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-1,k))&
+bsjy*(uy(i,j+2,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-2,k))&
+csjy*(uy(i,j+3,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=asjy*(uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-3,k))&
+bsjy*(uy(i,ny ,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-4,k))&
+csjy*(uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-5,k))
ty(i,ny-1,k)=asjy*(uy(i,ny ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-2,k))&
+bsjy*(uy(i,ny-1,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-3,k))&
+csjy*(uy(i,ny-2,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-4,k))
ty(i,ny ,k)=asjy*(uy(i,ny-1,k)-uy(i,ny ,k)&
-uy(i,ny ,k)+uy(i,ny-1,k))&
+bsjy*(uy(i,ny-2,k)-uy(i,ny ,k)&
-uy(i,ny ,k)+uy(i,ny-2,k))&
+csjy*(uy(i,ny-3,k)-uy(i,ny ,k)&
-uy(i,ny ,k)+uy(i,ny-3,k))
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*ssy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*swy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-sfy(j)*ty(i,j+1,k))*swy(j)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=0._mytype
ty(i,2,k)=asjy*(uy(i,3,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,1,k))&
+bsjy*(uy(i,4,k)-uy(i,2,k)&
-uy(i,2,k)-uy(i,2,k))&
+csjy*(uy(i,5,k)-uy(i,2,k)&
-uy(i,2,k)-uy(i,3,k))
ty(i,3,k)=asjy*(uy(i,4,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,2,k))&
+bsjy*(uy(i,5,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,1,k))&
+csjy*(uy(i,6,k)-uy(i,3,k)&
-uy(i,3,k)-uy(i,2,k))
enddo
enddo
do k=1,nz
do j=4,ny-3
do i=1,nx
ty(i,j,k)=asjy*(uy(i,j+1,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-1,k))&
+bsjy*(uy(i,j+2,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-2,k))&
+csjy*(uy(i,j+3,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=asjy*( uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-3,k))&
+bsjy*( uy(i,ny ,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-4,k))&
+csjy*(-uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-5,k))
ty(i,ny-1,k)=asjy*( uy(i,ny ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-2,k))&
+bsjy*(-uy(i,ny-1,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-3,k))&
+csjy*(-uy(i,ny-2,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-4,k))
ty(i,ny ,k)=0._mytype
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*ssy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*swy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-sfy(j)*ty(i,j+1,k))*swy(j)
enddo
enddo
enddo
endif
endif
if (ncly==2) then
do k=1,nz
do i=1,nx
ty(i,1,k)=as1y*uy(i,1,k)+bs1y*uy(i,2,k)&
+cs1y*uy(i,3,k)+ds1y*uy(i,4,k)
ty(i,2,k)=as2y*(uy(i,3,k)-uy(i,2,k)&
-uy(i,2,k)+uy(i,1,k))
ty(i,3,k)=as3y*(uy(i,4,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,2,k))&
+bs3y*(uy(i,5,k)-uy(i,3,k)&
-uy(i,3,k)+uy(i,1,k))
enddo
enddo
do k=1,nz
do j=4,ny-3
do i=1,nx
ty(i,j,k)=asjy*(uy(i,j+1,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-1,k))&
+bsjy*(uy(i,j+2,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-2,k))&
+csjy*(uy(i,j+3,k)-uy(i,j ,k)&
-uy(i,j ,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=asty*(uy(i,ny-1,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-3,k))&
+bsty*(uy(i,ny ,k)-uy(i,ny-2,k)&
-uy(i,ny-2,k)+uy(i,ny-4,k))
ty(i,ny-1,k)=asmy*(uy(i,ny ,k)-uy(i,ny-1,k)&
-uy(i,ny-1,k)+uy(i,ny-2,k))
ty(i,ny ,k)=asny*uy(i,ny ,k)+bsny*uy(i,ny-1,k)&
+csny*uy(i,ny-2,k)+dsny*uy(i,ny-3,k)
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*ssy(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*swy(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-sfy(j)*ty(i,j+1,k))*swy(j)
enddo
enddo
enddo
endif
return
end subroutine deryy
!********************************************************************
!
subroutine derzz(tz,uz,rz,sz,sfz,ssz,swz,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tz,uz,rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nz) :: sfz,ssz,swz
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=askz*(uz(i,j,2)-uz(i,j,1 )&
-uz(i,j,1)+uz(i,j,nz ))&
+bskz*(uz(i,j,3)-uz(i,j,1 )&
-uz(i,j,1)+uz(i,j,nz-1))&
+cskz*(uz(i,j,4)-uz(i,j,1 )&
-uz(i,j,1)+uz(i,j,nz-2))
rz(i,j,1)=-1._mytype
tz(i,j,2)=askz*(uz(i,j,3)-uz(i,j,2 )&
-uz(i,j,2)+uz(i,j,1 ))&
+bskz*(uz(i,j,4)-uz(i,j,2 )&
-uz(i,j,2)+uz(i,j,nz))&
+cskz*(uz(i,j,5)-uz(i,j,2 )&
-uz(i,j,2)+uz(i,j,nz-1))
rz(i,j,2)=0._mytype
tz(i,j,3)=askz*(uz(i,j,4)-uz(i,j,3 )&
-uz(i,j,3)+uz(i,j,2 ))&
+bskz*(uz(i,j,5)-uz(i,j,3 )&
-uz(i,j,3)+uz(i,j,1 ))&
+cskz*(uz(i,j,6)-uz(i,j,3 )&
-uz(i,j,3)+uz(i,j,nz))
rz(i,j,3)=0._mytype
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=askz*(uz(i,j,k+1)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-1))&
+bskz*(uz(i,j,k+2)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-2))&
+cskz*(uz(i,j,k+3)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-3))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=askz*(uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-3))&
+bskz*(uz(i,j,nz )-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-4))&
+cskz*(uz(i,j,1 )-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-5))
rz(i,j,nz-2)=0._mytype
tz(i,j,nz-1)=askz*(uz(i,j,nz )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-2))&
+bskz*(uz(i,j,1 )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-3))&
+cskz*(uz(i,j,2 )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-4))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz )=askz*(uz(i,j,1 )-uz(i,j,nz )&
-uz(i,j,nz)+uz(i,j,nz-1))&
+bskz*(uz(i,j,2 )-uz(i,j,nz )&
-uz(i,j,nz)+uz(i,j,nz-2))&
+cskz*(uz(i,j,3 )-uz(i,j,nz )&
-uz(i,j,nz)+uz(i,j,nz-3))
rz(i,j,nz )=alsakz
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*ssz(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*ssz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*swz(nz)
rz(i,j,nz)=rz(i,j,nz)*swz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-sfz(k)*tz(i,j,k+1))*swz(k)
rz(i,j,k)=(rz(i,j,k)-sfz(k)*rz(i,j,k+1))*swz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=( tz(i,j,1)-alsakz*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-alsakz*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if (nclz==1) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=askz*(uz(i,j,2)-uz(i,j,1)&
-uz(i,j,1)+uz(i,j,2))&
+bskz*(uz(i,j,3)-uz(i,j,1)&
-uz(i,j,1)+uz(i,j,3))&
+cskz*(uz(i,j,4)-uz(i,j,1)&
-uz(i,j,1)+uz(i,j,4))
tz(i,j,2)=askz*(uz(i,j,3)-uz(i,j,2)&
-uz(i,j,2)+uz(i,j,1))&
+bskz*(uz(i,j,4)-uz(i,j,2)&
-uz(i,j,2)+uz(i,j,2))&
+cskz*(uz(i,j,5)-uz(i,j,2)&
-uz(i,j,2)+uz(i,j,3))
tz(i,j,3)=askz*(uz(i,j,4)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,2))&
+bskz*(uz(i,j,5)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,1))&
+cskz*(uz(i,j,6)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,2))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=askz*(uz(i,j,k+1)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-1))&
+bskz*(uz(i,j,k+2)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-2))&
+cskz*(uz(i,j,k+3)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=askz*(uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-3))&
+bskz*(uz(i,j,nz )-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-4))&
+cskz*(uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-5))
tz(i,j,nz-1)=askz*(uz(i,j,nz )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-2))&
+bskz*(uz(i,j,nz-1)-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-3))&
+cskz*(uz(i,j,nz-2)-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-4))
tz(i,j,nz )=askz*(uz(i,j,nz-1)-uz(i,j,nz )&
-uz(i,j,nz )+uz(i,j,nz-1))&
+bskz*(uz(i,j,nz-2)-uz(i,j,nz )&
-uz(i,j,nz )+uz(i,j,nz-2))&
+cskz*(uz(i,j,nz-3)-uz(i,j,nz )&
-uz(i,j,nz )+uz(i,j,nz-3))
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*ssz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*swz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-sfz(k)*tz(i,j,k+1))*swz(k)
enddo
enddo
enddo
endif
if (npaire==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=0._mytype
tz(i,j,2)=askz*(uz(i,j,3)-uz(i,j,2)&
-uz(i,j,2)+uz(i,j,1))&
+bskz*(uz(i,j,4)-uz(i,j,2)&
-uz(i,j,2)-uz(i,j,2))&
+cskz*(uz(i,j,5)-uz(i,j,2)&
-uz(i,j,2)-uz(i,j,3))
tz(i,j,3)=askz*(uz(i,j,4)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,2))&
+bskz*(uz(i,j,5)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,1))&
+cskz*(uz(i,j,6)-uz(i,j,3)&
-uz(i,j,3)-uz(i,j,2))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=askz*(uz(i,j,k+1)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-1))&
+bskz*(uz(i,j,k+2)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-2))&
+cskz*(uz(i,j,k+3)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=askz*( uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-3))&
+bskz*( uz(i,j,nz )-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-4))&
+cskz*(-uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-5))
tz(i,j,nz-1)=askz*( uz(i,j,nz )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-2))&
+bskz*(-uz(i,j,nz-1)-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-3))&
+cskz*(-uz(i,j,nz-2)-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-4))
tz(i,j,nz )=0._mytype
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*ssz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*swz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-sfz(k)*tz(i,j,k+1))*swz(k)
enddo
enddo
enddo
endif
endif
if (nclz==2) then
do j=1,ny
do i=1,nx
tz(i,j,1)=as1z*uz(i,j,1)+bs1z*uz(i,j,2)&
+cs1z*uz(i,j,3)+ds1z*uz(i,j,4)
tz(i,j,2)=as2z*(uz(i,j,3)-uz(i,j,2)&
-uz(i,j,2)+uz(i,j,1))
tz(i,j,3)=as3z*(uz(i,j,4)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,2))&
+bs3z*(uz(i,j,5)-uz(i,j,3)&
-uz(i,j,3)+uz(i,j,1))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=askz*(uz(i,j,k+1)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-1))&
+bskz*(uz(i,j,k+2)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-2))&
+cskz*(uz(i,j,k+3)-uz(i,j,k )&
-uz(i,j,k )+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=astz*(uz(i,j,nz-1)-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-3))&
+bstz*(uz(i,j,nz )-uz(i,j,nz-2)&
-uz(i,j,nz-2)+uz(i,j,nz-4))
tz(i,j,nz-1)=asmz*(uz(i,j,nz )-uz(i,j,nz-1)&
-uz(i,j,nz-1)+uz(i,j,nz-2))
tz(i,j,nz )=asnz*uz(i,j,nz )+bsnz*uz(i,j,nz-1)&
+csnz*uz(i,j,nz-2)+dsnz*uz(i,j,nz-3)
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*ssz(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*swz(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-sfz(k)*tz(i,j,k+1))*swz(k)
enddo
enddo
enddo
endif
return
end subroutine derzz
!********************************************************************
!
subroutine decx6(tx,ux,rx,sx,cfx6,csx6,cwx6,nx,nxm,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,nxm,ny,nz,npaire
real(mytype), dimension(nxm,ny,nz) :: tx
real(mytype), dimension(nx,ny,nz) :: ux,rx
real(mytype), dimension(ny,nz) :: sx
real(mytype), dimension(nxm) :: cfx6,csx6,cwx6
integer :: i,j,k,nyz
nyz=ny*nz
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=acix6*(ux(2,j,k)-ux(1 ,j,k))&
+bcix6*(ux(3,j,k)-ux(nx,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=acix6*(ux(3,j,k)-ux(2 ,j,k))&
+bcix6*(ux(4,j,k)-ux(1,j,k))
rx(2,j,k)=0._mytype
do i=3,nx-2
tx(i,j,k)=acix6*(ux(i+1,j,k)-ux(i,j,k))&
+bcix6*(ux(i+2,j,k)-ux(i-1,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-1,j,k)=acix6*(ux(nx,j,k)-ux(nx-1,j,k))&
+bcix6*(ux(1 ,j,k)-ux(nx-2,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx ,j,k)=acix6*(ux(1,j,k)-ux(nx,j,k))&
+bcix6*(ux(2,j,k)-ux(nx-1,j,k))
rx(nx ,j,k)=alcaix6
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*csx6(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*csx6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*cwx6(nx)
rx(nx,j,k)=rx(nx,j,k)*cwx6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cfx6(i)*tx(i+1,j,k))*cwx6(i)
rx(i,j,k)=(rx(i,j,k)-cfx6(i)*rx(i+1,j,k))*cwx6(i)
enddo
sx(j,k)=(tx(1,j,k)-alcaix6*tx(nx,j,k))/&
(1._mytype+rx(1,j,k)-alcaix6*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if ((nclx==1).or.(nclx==2)) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=acix6*(ux(2,j,k)-ux(1,j,k))&
+bcix6*(ux(3,j,k)-ux(2,j,k))
tx(2,j,k)=acix6*(ux(3,j,k)-ux(2,j,k))&
+bcix6*(ux(4,j,k)-ux(1,j,k))
do i=3,nxm-2
tx(i,j,k)=acix6*(ux(i+1,j,k)-ux(i,j,k))&
+bcix6*(ux(i+2,j,k)-ux(i-1,j,k))
enddo
tx(nxm-1,j,k)=acix6*(ux(nxm,j,k)-ux(nxm-1,j,k))&
+bcix6*(ux(nx,j,k)-ux(nxm-2,j,k))
tx(nxm,j,k)=acix6*(ux(nx,j,k)-ux(nxm,j,k))&
+bcix6*(ux(nxm,j,k)-ux(nxm-1,j,k))
do i=2,nxm
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*csx6(i)
enddo
tx(nxm,j,k)=tx(nxm,j,k)*cwx6(nxm)
do i=nxm-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cfx6(i)*tx(i+1,j,k))*cwx6(i)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=acix6*(ux(2,j,k)-ux(1,j,k))&
+bcix6*(ux(3,j,k)-2._mytype*ux(1,j,k)+ux(2,j,k))
tx(2,j,k)=acix6*(ux(3,j,k)-ux(2,j,k))&
+bcix6*(ux(4,j,k)-ux(1,j,k))
do i=3,nxm-2
tx(i,j,k)=acix6*(ux(i+1,j,k)-ux(i,j,k))&
+bcix6*(ux(i+2,j,k)-ux(i-1,j,k))
enddo
tx(nxm-1,j,k)=acix6*(ux(nxm,j,k)-ux(nxm-1,j,k))&
+bcix6*(ux(nx,j,k)-ux(nxm-2,j,k))
tx(nxm,j,k)=acix6*(ux(nx,j,k)-ux(nxm,j,k))&
+bcix6*(2._mytype*ux(nx,j,k)-ux(nxm,j,k)-ux(nxm-1,j,k))
do i=2,nxm
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*csx6(i)
enddo
tx(nxm,j,k)=tx(nxm,j,k)*cwx6(nxm)
do i=nxm-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cfx6(i)*tx(i+1,j,k))*cwx6(i)
enddo
enddo
enddo
endif
endif
return
end subroutine decx6
!********************************************************************
!
subroutine inter6(tx,ux,rx,sx,cifx6,cisx6,ciwx6,nx,nxm,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,nxm,ny,nz,npaire,i,j,nyz,k
real(mytype), dimension(nxm,ny,nz) :: tx
real(mytype), dimension(nx,ny,nz) :: ux,rx
real(mytype), dimension(ny,nz) :: sx
real(mytype), dimension(nxm) :: cifx6,cisx6,ciwx6
nyz=ny*nz
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=aicix6*(ux(2,j,k)+ux(1 ,j,k))&
+bicix6*(ux(3,j,k)+ux(nx,j,k))&
+cicix6*(ux(4,j,k)+ux(nx-1,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=aicix6*(ux(3,j,k)+ux(2 ,j,k))&
+bicix6*(ux(4,j,k)+ux(1,j,k))&
+cicix6*(ux(5,j,k)+ux(nx,j,k))
rx(2,j,k)=0._mytype
do i=3,nx-3
tx(i,j,k)=aicix6*(ux(i+1,j,k)+ux(i,j,k))&
+bicix6*(ux(i+2,j,k)+ux(i-1,j,k))&
+cicix6*(ux(i+3,j,k)+ux(i-2,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-2,j,k)=aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k))&
+bicix6*(ux(nx ,j,k)+ux(nx-3,j,k))&
+cicix6*(ux(1,j,k)+ux(nx-4,j,k))
rx(nx-2,j,k)=0._mytype
tx(nx-1,j,k)=aicix6*(ux(nx,j,k)+ux(nx-1,j,k))&
+bicix6*(ux(1 ,j,k)+ux(nx-2,j,k))&
+cicix6*(ux(2,j,k)+ux(nx-3,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx ,j,k)=aicix6*(ux(1,j,k)+ux(nx,j,k))&
+bicix6*(ux(2,j,k)+ux(nx-1,j,k))&
+cicix6*(ux(3,j,k)+ux(nx-2,j,k))
rx(nx ,j,k)=ailcaix6
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*cisx6(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*cisx6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*ciwx6(nx)
rx(nx,j,k)=rx(nx,j,k)*ciwx6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cifx6(i)*tx(i+1,j,k))*ciwx6(i)
rx(i,j,k)=(rx(i,j,k)-cifx6(i)*rx(i+1,j,k))*ciwx6(i)
enddo
sx(j,k)=(tx(1,j,k)-ailcaix6*tx(nx,j,k))/&
(1._mytype+rx(1,j,k)-ailcaix6*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if ((nclx==1).or.(nclx==2)) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=aicix6*(ux(2,j,k)+ux(1,j,k))&
+bicix6*(ux(3,j,k)+ux(2,j,k))&
+cicix6*(ux(4,j,k)+ux(3,j,k))
tx(2,j,k)=aicix6*(ux(3,j,k)+ux(2,j,k))&
+bicix6*(ux(4,j,k)+ux(1,j,k))&
+cicix6*(ux(5,j,k)+ux(2,j,k))
do i=3,nxm-2
tx(i,j,k)=aicix6*(ux(i+1,j,k)+ux(i,j,k))&
+bicix6*(ux(i+2,j,k)+ux(i-1,j,k))&
+cicix6*(ux(i+3,j,k)+ux(i-2,j,k))
enddo
tx(nxm-1,j,k)=aicix6*(ux(nxm,j,k)+ux(nxm-1,j,k))&
+bicix6*(ux(nx,j,k)+ux(nxm-2,j,k))&
+cicix6*(ux(nxm,j,k)+ux(nxm-3,j,k))
tx(nxm,j,k)=aicix6*(ux(nx,j,k)+ux(nxm,j,k))&
+bicix6*(ux(nxm,j,k)+ux(nxm-1,j,k))&
+cicix6*(ux(nxm-1,j,k)+ux(nxm-2,j,k))
do i=2,nxm
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*cisx6(i)
enddo
tx(nxm,j,k)=tx(nxm,j,k)*ciwx6(nxm)
do i=nxm-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cifx6(i)*tx(i+1,j,k))*ciwx6(i)
enddo
enddo
enddo
endif
endif
return
end subroutine inter6
!********************************************************************
!
subroutine deci6(tx,ux,rx,sx,cfi6,csi6,cwi6,cfx6,csx6,cwx6,nxm,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,nxm,ny,nz,npaire
real(mytype), dimension(nx,ny,nz) :: tx
real(mytype), dimension(nxm,ny,nz) :: ux,rx
real(mytype), dimension(ny,nz) :: sx
real(mytype), dimension(nx) :: cfi6,csi6,cwi6
real(mytype), dimension(nx) :: cfx6,csx6,cwx6
integer :: i,j,k
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=acix6*(ux(1,j,k)-ux(nx ,j,k))&
+bcix6*(ux(2,j,k)-ux(nx-1,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=acix6*(ux(2,j,k)-ux(1 ,j,k))&
+bcix6*(ux(3,j,k)-ux(nx,j,k))
rx(2,j,k)=0._mytype
do i=3,nx-2
tx(i,j,k)=acix6*(ux(i,j,k)-ux(i-1,j,k))&
+bcix6*(ux(i+1,j,k)-ux(i-2,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-1,j,k)=acix6*(ux(nx-1,j,k)-ux(nx-2,j,k))&
+bcix6*(ux(nx ,j,k)-ux(nx-3,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx ,j,k)=acix6*(ux(nx,j,k)-ux(nx-1,j,k))&
+bcix6*(ux(1,j,k)-ux(nx-2,j,k))
rx(nx ,j,k)=alcaix6
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*csx6(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*csx6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*cwx6(nx)
rx(nx,j,k)=rx(nx,j,k)*cwx6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cfx6(i)*tx(i+1,j,k))*cwx6(i)
rx(i,j,k)=(rx(i,j,k)-cfx6(i)*rx(i+1,j,k))*cwx6(i)
enddo
sx(j,k)=(tx(1,j,k)-alcaix6*tx(nx,j,k))/&
(1._mytype+rx(1,j,k)-alcaix6*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if ((nclx==1).or.(nclx==2)) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=0._mytype
tx(2,j,k)=acix6*(ux(2,j,k)-ux(1,j,k))&
+bcix6*(ux(3,j,k)-ux(1,j,k))
do i=3,nx-2
tx(i,j,k)=acix6*(ux(i,j,k)-ux(i-1,j,k))&
+bcix6*(ux(i+1,j,k)-ux(i-2,j,k))
enddo
tx(nx-1,j,k)=acix6*(ux(nx-1,j,k)-ux(nx-2,j,k))&
+bcix6*(ux(nx-1,j,k)-ux(nx-3,j,k))
tx(nx,j,k)=0._mytype
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*csi6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*cwi6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cfi6(i)*tx(i+1,j,k))*cwi6(i)
enddo
enddo
enddo
endif
endif
return
end subroutine deci6
!********************************************************************
!
subroutine interi6(tx,ux,rx,sx,cifi6,cisi6,ciwi6,cifx6,cisx6,ciwx6,&
nxm,nx,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivX
implicit none
integer :: nx,nxm,ny,nz,npaire
real(mytype), dimension(nx,ny,nz) :: tx,rx
real(mytype), dimension(nxm,ny,nz) :: ux
real(mytype), dimension(ny,nz) :: sx
real(mytype), dimension(nx) :: cifi6,cisi6,ciwi6
real(mytype), dimension(nx) :: cifx6,cisx6,ciwx6
integer :: i,j,k
if (nclx==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=aicix6*(ux(1,j,k)+ux(nx ,j,k))&
+bicix6*(ux(2,j,k)+ux(nx-1,j,k))&
+cicix6*(ux(3,j,k)+ux(nx-2,j,k))
rx(1,j,k)=-1._mytype
tx(2,j,k)=aicix6*(ux(2,j,k)+ux(1 ,j,k))&
+bicix6*(ux(3,j,k)+ux(nx,j,k))&
+cicix6*(ux(4,j,k)+ux(nx-1,j,k))
rx(2,j,k)=0._mytype
tx(3,j,k)=aicix6*(ux(3,j,k)+ux(2 ,j,k))&
+bicix6*(ux(4,j,k)+ux(1,j,k))&
+cicix6*(ux(5,j,k)+ux(nx,j,k))
rx(3,j,k)=0._mytype
do i=4,nx-2
tx(i,j,k)=aicix6*(ux(i,j,k)+ux(i-1,j,k))&
+bicix6*(ux(i+1,j,k)+ux(i-2,j,k))&
+cicix6*(ux(i+2,j,k)+ux(i-3,j,k))
rx(i,j,k)=0._mytype
enddo
tx(nx-1,j,k)=aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k))&
+bicix6*(ux(nx ,j,k)+ux(nx-3,j,k))&
+cicix6*(ux(1,j,k)+ux(nx-4,j,k))
rx(nx-1,j,k)=0._mytype
tx(nx ,j,k)=aicix6*(ux(nx,j,k)+ux(nx-1,j,k))&
+bicix6*(ux(1,j,k)+ux(nx-2,j,k))&
+cicix6*(ux(2,j,k)+ux(nx-3,j,k))
rx(nx ,j,k)=ailcaix6
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*cisx6(i)
rx(i,j,k)=rx(i,j,k)-rx(i-1,j,k)*cisx6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*ciwx6(nx)
rx(nx,j,k)=rx(nx,j,k)*ciwx6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cifx6(i)*tx(i+1,j,k))*ciwx6(i)
rx(i,j,k)=(rx(i,j,k)-cifx6(i)*rx(i+1,j,k))*ciwx6(i)
enddo
sx(j,k)=(tx(1,j,k)-ailcaix6*tx(nx,j,k))/&
(1._mytype+rx(1,j,k)-ailcaix6*rx(nx,j,k))
do i=1,nx
tx(i,j,k)=tx(i,j,k)-sx(j,k)*rx(i,j,k)
enddo
enddo
enddo
endif
if ((nclx==1).or.(nclx==2)) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=aicix6*(ux(1,j,k)+ux(1,j,k))&
+bicix6*(ux(2,j,k)+ux(2,j,k))&
+cicix6*(ux(3,j,k)+ux(3,j,k))
tx(2,j,k)=aicix6*(ux(2,j,k)+ux(1,j,k))&
+bicix6*(ux(3,j,k)+ux(1,j,k))&
+cicix6*(ux(4,j,k)+ux(2,j,k))
tx(3,j,k)=aicix6*(ux(3,j,k)+ux(2,j,k))&
+bicix6*(ux(4,j,k)+ux(1,j,k))&
+cicix6*(ux(5,j,k)+ux(1,j,k))
do i=4,nx-3
tx(i,j,k)=aicix6*(ux(i,j,k)+ux(i-1,j,k))&
+bicix6*(ux(i+1,j,k)+ux(i-2,j,k))&
+cicix6*(ux(i+2,j,k)+ux(i-3,j,k))
enddo
tx(nx-2,j,k)=aicix6*(ux(nx-2,j,k)+ux(nx-3,j,k))&
+bicix6*(ux(nx-1,j,k)+ux(nx-4,j,k))&
+cicix6*(ux(nx-1,j,k)+ux(nx-5,j,k))
tx(nx-1,j,k)=aicix6*(ux(nx-1,j,k)+ux(nx-2,j,k))&
+bicix6*(ux(nx-1,j,k)+ux(nx-3,j,k))&
+cicix6*(ux(nx-2,j,k)+ux(nx-4,j,k))
tx(nx,j,k)=aicix6*(ux(nx-1,j,k)+ux(nx-1,j,k))&
+bicix6*(ux(nx-2,j,k)+ux(nx-2,j,k))&
+cicix6*(ux(nx-3,j,k)+ux(nx-3,j,k))
do i=2,nx
tx(i,j,k)=tx(i,j,k)-tx(i-1,j,k)*cisi6(i)
enddo
tx(nx,j,k)=tx(nx,j,k)*ciwi6(nx)
do i=nx-1,1,-1
tx(i,j,k)=(tx(i,j,k)-cifi6(i)*tx(i+1,j,k))*ciwi6(i)
enddo
enddo
enddo
endif
endif
return
end subroutine interi6
!********************************************************************
!
subroutine intery6(ty,uy,ry,sy,cify6,cisy6,ciwy6,nx,ny,nym,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nym,nz,npaire
real(mytype), dimension(nx,nym,nz) :: ty
real(mytype), dimension(nx,ny,nz) :: uy,ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(nym) :: cify6,cisy6,ciwy6
integer :: i,j,k
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aiciy6*(uy(i,2,k)+uy(i,1,k))&
+biciy6*(uy(i,3,k)+uy(i,ny,k))&
+ciciy6*(uy(i,4,k)+uy(i,ny-1,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=aiciy6*(uy(i,3,k)+uy(i,2,k))&
+biciy6*(uy(i,4,k)+uy(i,1,k))&
+ciciy6*(uy(i,5,k)+uy(i,ny,k))
ry(i,2,k)=0._mytype
enddo
enddo
do k=1,nz
do j=3,ny-3
do i=1,nx
ty(i,j,k)=aiciy6*(uy(i,j+1,k)+uy(i,j,k))&
+biciy6*(uy(i,j+2,k)+uy(i,j-1,k))&
+ciciy6*(uy(i,j+3,k)+uy(i,j-2,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k))&
+biciy6*(uy(i,ny,k)+uy(i,ny-3,k))&
+ciciy6*(uy(i,1,k)+uy(i,ny-4,k))
ry(i,ny-2,k)=0._mytype
ty(i,ny-1,k)=aiciy6*(uy(i,ny,k)+uy(i,ny-1,k))&
+biciy6*(uy(i,1,k)+uy(i,ny-2,k))&
+ciciy6*(uy(i,2,k)+uy(i,ny-3,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny,k)=aiciy6*(uy(i,1,k)+uy(i,ny,k))&
+biciy6*(uy(i,2,k)+uy(i,ny-1,k))&
+ciciy6*(uy(i,3,k)+uy(i,ny-2,k))
ry(i,ny,k)=ailcaiy6
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*cisy6(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*cisy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*ciwy6(ny)
ry(i,ny,k)=ry(i,ny,k)*ciwy6(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cify6(j)*ty(i,j+1,k))*ciwy6(j)
ry(i,j,k)=(ry(i,j,k)-cify6(j)*ry(i,j+1,k))*ciwy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=(ty(i,1,k)-ailcaiy6*ty(i,ny,k))&
/(1._mytype+ry(i,1,k)-ailcaiy6*ry(i,ny,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if ((ncly==1).or.(ncly==2)) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aiciy6*(uy(i,2,k)+uy(i,1,k))&
+biciy6*(uy(i,3,k)+uy(i,2,k))&
+ciciy6*(uy(i,4,k)+uy(i,3,k))
ty(i,2,k)=aiciy6*(uy(i,3,k)+uy(i,2,k))&
+biciy6*(uy(i,4,k)+uy(i,1,k))&
+ciciy6*(uy(i,5,k)+uy(i,2,k))
enddo
enddo
do k=1,nz
do j=3,nym-2
do i=1,nx
ty(i,j,k)=aiciy6*(uy(i,j+1,k)+uy(i,j,k))&
+biciy6*(uy(i,j+2,k)+uy(i,j-1,k))&
+ciciy6*(uy(i,j+3,k)+uy(i,j-2,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,nym-1,k)=aiciy6*(uy(i,nym,k)+uy(i,nym-1,k))&
+biciy6*(uy(i,ny,k)+uy(i,nym-2,k))&
+ciciy6*(uy(i,nym,k)+uy(i,nym-3,k))
ty(i,nym,k)=aiciy6*(uy(i,ny,k)+uy(i,nym,k))&
+biciy6*(uy(i,nym,k)+uy(i,nym-1,k))&
+ciciy6*(uy(i,nym-1,k)+uy(i,nym-2,k))
enddo
enddo
do k=1,nz
do j=2,nym
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*cisy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,nym,k)=ty(i,nym,k)*ciwy6(nym)
enddo
enddo
do k=1,nz
do j=nym-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cify6(j)*ty(i,j+1,k))*ciwy6(j)
enddo
enddo
enddo
endif
endif
return
end subroutine intery6
!********************************************************************
!
subroutine decy6(ty,uy,ry,sy,cfy6,csy6,cwy6,ppyi,nx,ny,nym,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nym,nz,npaire
real(mytype), dimension(nx,nym,nz) :: ty
real(mytype), dimension(nx,ny,nz) :: uy
real(mytype), dimension(nx,ny,nz) :: ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(nym) :: cfy6,csy6,cwy6,ppyi
integer :: i,j,k
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aciy6*(uy(i,2,k)-uy(i,1,k))&
+bciy6*(uy(i,3,k)-uy(i,ny,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=aciy6*(uy(i,3,k)-uy(i,2,k))&
+bciy6*(uy(i,4,k)-uy(i,1,k))
ry(i,2,k)=0._mytype
enddo
enddo
do k=1,nz
do j=3,ny-2
do i=1,nx
ty(i,j,k)=aciy6*(uy(i,j+1,k)-uy(i,j,k))&
+bciy6*(uy(i,j+2,k)-uy(i,j-1,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=aciy6*(uy(i,ny,k)-uy(i,ny-1,k))&
+bciy6*(uy(i,1,k)-uy(i,ny-2,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny,k)=aciy6*(uy(i,1,k)-uy(i,ny,k))&
+bciy6*(uy(i,2,k)-uy(i,ny-1,k))
ry(i,ny,k)=alcaiy6
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*csy6(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*csy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*cwy6(ny)
ry(i,ny,k)=ry(i,ny,k)*cwy6(ny)
enddo
enddo
do k=1,nz
do j=ny-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cfy6(j)*ty(i,j+1,k))*cwy6(j)
ry(i,j,k)=(ry(i,j,k)-cfy6(j)*ry(i,j+1,k))*cwy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=(ty(i,1,k)-alcaiy6*ty(i,ny,k))&
/(1._mytype+ry(i,1,k)-alcaiy6*ry(i,ny,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if ((ncly==1).or.(ncly==2)) then
if (npaire==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aciy6*(uy(i,2,k)-uy(i,1,k))&
+bciy6*(uy(i,3,k)-2._mytype*uy(i,1,k)+uy(i,2,k))
ty(i,2,k)=aciy6*(uy(i,3,k)-uy(i,2,k))&
+bciy6*(uy(i,4,k)-uy(i,1,k))
enddo
enddo
do k=1,nz
do j=3,nym-2
do i=1,nx
ty(i,j,k)=aciy6*(uy(i,j+1,k)-uy(i,j,k))&
+bciy6*(uy(i,j+2,k)-uy(i,j-1,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,nym-1,k)=aciy6*(uy(i,nym,k)-uy(i,nym-1,k))&
+bciy6*(uy(i,ny,k)-uy(i,nym-2,k))
ty(i,nym,k)=aciy6*(uy(i,ny,k)-uy(i,nym,k))&
+bciy6*(2._mytype*uy(i,ny,k)-uy(i,nym,k)-uy(i,nym-1,k))
enddo
enddo
do k=1,nz
do j=2,nym
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*csy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,nym,k)=ty(i,nym,k)*cwy6(nym)
enddo
enddo
do k=1,nz
do j=nym-1,1,-1
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cfy6(j)*ty(i,j+1,k))*cwy6(j)
enddo
enddo
enddo
endif
endif
if (istret.ne.0) then
do k=1,nz
do j=1,nym
do i=1,nx
ty(i,j,k)=ty(i,j,k)*ppyi(j)
enddo
enddo
enddo
endif
return
end subroutine decy6
!********************************************************************
!
subroutine interiy6(ty,uy,ry,sy,cifi6y,cisi6y,ciwi6y,cify6,cisy6,ciwy6,&
nx,nym,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nym,nz,npaire
real(mytype), dimension(nx,ny,nz) :: ty
real(mytype), dimension(nx,nym,nz) :: uy
real(mytype), dimension(nx,ny,nz) :: ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(ny) :: cifi6y,cisi6y,ciwi6y
real(mytype), dimension(ny) :: cify6,cisy6,ciwy6
integer :: i,j,k
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aiciy6*(uy(i,1,k)+uy(i,ny,k))&
+biciy6*(uy(i,2,k)+uy(i,ny-1,k))&
+ciciy6*(uy(i,3,k)+uy(i,ny-2,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=aiciy6*(uy(i,2,k)+uy(i,1,k))&
+biciy6*(uy(i,3,k)+uy(i,ny,k))&
+ciciy6*(uy(i,4,k)+uy(i,ny-1,k))
ry(i,2,k)=0._mytype
ty(i,3,k)=aiciy6*(uy(i,3,k)+uy(i,2,k))&
+biciy6*(uy(i,4,k)+uy(i,1,k))&
+ciciy6*(uy(i,5,k)+uy(i,ny,k))
ry(i,3,k)=0._mytype
enddo
enddo
do k=1,nz
do j=4,ny-2
do i=1,nx
ty(i,j,k)=aiciy6*(uy(i,j,k)+uy(i,j-1,k))&
+biciy6*(uy(i,j+1,k)+uy(i,j-2,k))&
+ciciy6*(uy(i,j+2,k)+uy(i,j-3,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k))&
+biciy6*(uy(i,ny,k)+uy(i,ny-3,k))&
+ciciy6*(uy(i,1,k)+uy(i,ny-4,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny,k)=aiciy6*(uy(i,ny,k)+uy(i,ny-1,k))&
+biciy6*(uy(i,1,k)+uy(i,ny-2,k))&
+ciciy6*(uy(i,2,k)+uy(i,ny-3,k))
ry(i,ny,k)=ailcaiy6
enddo
enddo
do k=1,nz
do j=2,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*cisy6(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*cisy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*ciwy6(ny)
ry(i,ny,k)=ry(i,ny,k)*ciwy6(ny)
enddo
enddo
do j=ny-1,1,-1
do k=1,nz
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cify6(j)*ty(i,j+1,k))*ciwy6(j)
ry(i,j,k)=(ry(i,j,k)-cify6(j)*ry(i,j+1,k))*ciwy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=(ty(i,1,k)-ailcaiy6*ty(i,ny,k))/&
(1._mytype+ry(i,1,k)-ailcaiy6*ry(i,ny,k))
enddo
enddo
do j=1,ny
do k=1,nz
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if ((ncly==1).or.(ncly==2)) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aiciy6*(uy(i,1,k)+uy(i,1,k))&
+biciy6*(uy(i,2,k)+uy(i,2,k))&
+ciciy6*(uy(i,3,k)+uy(i,3,k))
ty(i,2,k)=aiciy6*(uy(i,2,k)+uy(i,1,k))&
+biciy6*(uy(i,3,k)+uy(i,1,k))&
+ciciy6*(uy(i,4,k)+uy(i,2,k))
ty(i,3,k)=aiciy6*(uy(i,3,k)+uy(i,2,k))&
+biciy6*(uy(i,4,k)+uy(i,1,k))&
+ciciy6*(uy(i,5,k)+uy(i,1,k))
enddo
enddo
do j=4,ny-3
do k=1,nz
do i=1,nx
ty(i,j,k)=aiciy6*(uy(i,j,k)+uy(i,j-1,k))&
+biciy6*(uy(i,j+1,k)+uy(i,j-2,k))&
+ciciy6*(uy(i,j+2,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-2,k)=aiciy6*(uy(i,ny-2,k)+uy(i,ny-3,k))&
+biciy6*(uy(i,ny-1,k)+uy(i,ny-4,k))&
+ciciy6*(uy(i,ny-1,k)+uy(i,ny-5,k))
ty(i,ny-1,k)=aiciy6*(uy(i,ny-1,k)+uy(i,ny-2,k))&
+biciy6*(uy(i,ny-1,k)+uy(i,ny-3,k))&
+ciciy6*(uy(i,ny-2,k)+uy(i,ny-4,k))
ty(i,ny,k)=aiciy6*(uy(i,ny-1,k)+uy(i,ny-1,k))&
+biciy6*(uy(i,ny-2,k)+uy(i,ny-2,k))&
+ciciy6*(uy(i,ny-3,k)+uy(i,ny-3,k))
enddo
enddo
do j=2,ny
do k=1,nz
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*cisi6y(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*ciwi6y(ny)
enddo
enddo
do j=ny-1,1,-1
do k=1,nz
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cifi6y(j)*ty(i,j+1,k))*ciwi6y(j)
enddo
enddo
enddo
endif
endif
return
end subroutine interiy6
!********************************************************************
!
subroutine deciy6(ty,uy,ry,sy,cfi6y,csi6y,cwi6y,cfy6,csy6,cwy6,&
ppy,nx,nym,ny,nz,npaire)
!
!********************************************************************
USE param
USE derivY
implicit none
integer :: nx,ny,nym,nz,npaire
real(mytype), dimension(nx,ny,nz) :: ty
real(mytype), dimension(nx,nym,nz) :: uy
real(mytype), dimension(nx,ny,nz) :: ry
real(mytype), dimension(nx,nz) :: sy
real(mytype), dimension(ny) :: cfi6y,csi6y,cwi6y,ppy
real(mytype), dimension(nym) :: cfy6,csy6,cwy6
integer :: i,j,k
if (ncly==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=aciy6*(uy(i,1,k)-uy(i,ny,k))&
+bciy6*(uy(i,2,k)-uy(i,ny-1,k))
ry(i,1,k)=-1._mytype
ty(i,2,k)=aciy6*(uy(i,2,k)-uy(i,1,k))&
+bciy6*(uy(i,3,k)-uy(i,ny,k))
ry(i,2,k)=0._mytype
enddo
enddo
do j=3,ny-2
do k=1,nz
do i=1,nx
ty(i,j,k)=aciy6*(uy(i,j,k)-uy(i,j-1,k))&
+bciy6*(uy(i,j+1,k)-uy(i,j-2,k))
ry(i,j,k)=0._mytype
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=aciy6*(uy(i,ny-1,k)-uy(i,ny-2,k))&
+bciy6*(uy(i,ny,k)-uy(i,ny-3,k))
ry(i,ny-1,k)=0._mytype
ty(i,ny,k)=aciy6*(uy(i,ny,k)-uy(i,ny-1,k))&
+bciy6*(uy(i,1,k)-uy(i,ny-2,k))
ry(i,ny,k)=alcaiy6
enddo
enddo
do j=2,ny
do k=1,nz
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*csy6(j)
ry(i,j,k)=ry(i,j,k)-ry(i,j-1,k)*csy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*cwy6(ny)
ry(i,ny,k)=ry(i,ny,k)*cwy6(ny)
enddo
enddo
do j=ny-1,1,-1
do k=1,nz
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cfy6(j)*ty(i,j+1,k))*cwy6(j)
ry(i,j,k)=(ry(i,j,k)-cfy6(j)*ry(i,j+1,k))*cwy6(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
sy(i,k)=(ty(i,1,k)-alcaiy6*ty(i,ny,k))&
/(1._mytype+ry(i,1,k)-alcaiy6*ry(i,ny,k))
enddo
enddo
do j=1,ny
do k=1,nz
do i=1,nx
ty(i,j,k)=ty(i,j,k)-sy(i,k)*ry(i,j,k)
enddo
enddo
enddo
endif
if ((ncly==1).or.(ncly==2)) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=0._mytype
ty(i,2,k)=aciy6*(uy(i,2,k)-uy(i,1,k))&
+bciy6*(uy(i,3,k)-uy(i,1,k))
enddo
enddo
do j=3,ny-2
do k=1,nz
do i=1,nx
ty(i,j,k)=aciy6*(uy(i,j,k)-uy(i,j-1,k))&
+bciy6*(uy(i,j+1,k)-uy(i,j-2,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny-1,k)=aciy6*(uy(i,ny-1,k)-uy(i,ny-2,k))&
+bciy6*(uy(i,ny-1,k)-uy(i,ny-3,k))
ty(i,ny,k)=0._mytype
enddo
enddo
do j=2,ny
do k=1,nz
do i=1,nx
ty(i,j,k)=ty(i,j,k)-ty(i,j-1,k)*csi6y(j)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*cwi6y(ny)
enddo
enddo
do j=ny-1,1,-1
do k=1,nz
do i=1,nx
ty(i,j,k)=(ty(i,j,k)-cfi6y(j)*ty(i,j+1,k))*cwi6y(j)
enddo
enddo
enddo
endif
endif
if (istret.ne.0) then
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ty(i,j,k)*ppy(j)
enddo
enddo
enddo
endif
return
end subroutine deciy6
!********************************************************************
!
subroutine decz6(tz,uz,rz,sz,cfz6,csz6,cwz6,nx,ny,nz,nzm,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,ny,nz,nzm,npaire
real(mytype), dimension(nx,ny,nzm) :: tz
real(mytype), dimension(nx,ny,nz) :: uz
real(mytype), dimension(nx,ny,nz) :: rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nzm) :: cfz6,csz6,cwz6
integer :: i,j,k
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aciz6*(uz(i,j,2)-uz(i,j,1))&
+bciz6*(uz(i,j,3)-uz(i,j,nz))
rz(i,j,1)=-1._mytype
tz(i,j,2)=aciz6*(uz(i,j,3)-uz(i,j,2))&
+bciz6*(uz(i,j,4)-uz(i,j,1))
rz(i,j,2)=0._mytype
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aciz6*(uz(i,j,k+1)-uz(i,j,k))&
+bciz6*(uz(i,j,k+2)-uz(i,j,k-1))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=aciz6*(uz(i,j,nz)-uz(i,j,nz-1))&
+bciz6*(uz(i,j,1)-uz(i,j,nz-2))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz)=aciz6*(uz(i,j,1)-uz(i,j,nz))&
+bciz6*(uz(i,j,2)-uz(i,j,nz-1))
rz(i ,j,nz)=alcaiz6
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*csz6(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*csz6(k)
enddo
enddo
enddo
do i=1,nx
do j=1,ny
tz(i,j,nz)=tz(i,j,nz)*cwz6(nz)
rz(i,j,nz)=rz(i,j,nz)*cwz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cfz6(k)*tz(i,j,k+1))*cwz6(k)
rz(i,j,k)=(rz(i,j,k)-cfz6(k)*rz(i,j,k+1))*cwz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=(tz(i,j,1)-alcaiz6*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-alcaiz6*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if ((nclz==1).or.(nclz==2)) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aciz6*(uz(i,j,2)-uz(i,j,1))&
+bciz6*(uz(i,j,3)-uz(i,j,2))
tz(i,j,2)=aciz6*(uz(i,j,3)-uz(i,j,2))&
+bciz6*(uz(i,j,4)-uz(i,j,1))
enddo
enddo
do k=3,nzm-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aciz6*(uz(i,j,k+1)-uz(i,j,k))&
+bciz6*(uz(i,j,k+2)-uz(i,j,k-1))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm-1)=aciz6*(uz(i,j,nzm)-uz(i,j,nzm-1))&
+bciz6*(uz(nz,j,k)-uz(nzm-2,j,k))
tz(i,j,nzm)=aciz6*(uz(i,j,nz)-uz(i,j,nzm))&
+bciz6*(uz(i,j,nzm)-uz(i,j,nzm-1))
enddo
enddo
do k=2,nzm
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*csz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm)=tz(i,j,nzm)*cwz6(nzm)
enddo
enddo
do k=nzm-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cfz6(k)*tz(i,j,k+1))*cwz6(k)
enddo
enddo
enddo
endif
if (npaire==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aciz6*(uz(i,j,2)-uz(i,j,1))&
+bciz6*(uz(i,j,3)-2._mytype*uz(i,j,1)+uz(i,j,2))
tz(i,j,2)=aciz6*(uz(i,j,3)-uz(i,j,2))&
+bciz6*(uz(i,j,4)-uz(i,j,1))
enddo
enddo
do k=3,nzm-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aciz6*(uz(i,j,k+1)-uz(i,j,k))&
+bciz6*(uz(i,j,k+2)-uz(i,j,k-1))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm-1)=aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2))&
+bciz6*(uz(i,j,nz)-uz(i,j,nz-3))
tz(i,j,nzm)=aciz6*(uz(i,j,nz)-uz(i,j,nz-1))&
+bciz6*(2._mytype*uz(i,j,nz)-uz(i,j,nz-1)-uz(i,j,nz-2))
enddo
enddo
do k=2,nzm
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*csz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm)=tz(i,j,nzm)*cwz6(nzm)
enddo
enddo
do k=nzm-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cfz6(k)*tz(i,j,k+1))*cwz6(k)
enddo
enddo
enddo
endif
endif
return
end subroutine decz6
!********************************************************************
!
subroutine interz6(tz,uz,rz,sz,cifz6,cisz6,ciwz6,nx,ny,nz,nzm,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,ny,nz,nzm,npaire
real(mytype), dimension(nx,ny,nzm) :: tz
real(mytype), dimension(nx,ny,nz) :: uz,rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nzm) :: cifz6,cisz6,ciwz6
integer :: i,j,k
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aiciz6*(uz(i,j,2)+uz(i,j,1))&
+biciz6*(uz(i,j,3)+uz(i,j,nz))&
+ciciz6*(uz(i,j,4)+uz(i,j,nz-1))
rz(i,j,1)=-1._mytype
tz(i,j,2)=aiciz6*(uz(i,j,3)+uz(i,j,2))&
+biciz6*(uz(i,j,4)+uz(i,j,1))&
+ciciz6*(uz(i,j,5)+uz(i,j,nz))
rz(i,j,2)=0._mytype
enddo
enddo
do k=3,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=aiciz6*(uz(i,j,k+1)+uz(i,j,k))&
+biciz6*(uz(i,j,k+2)+uz(i,j,k-1))&
+ciciz6*(uz(i,j,k+3)+uz(i,j,k-2))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2))&
+biciz6*(uz(i,j,nz)+uz(i,j,nz-3))&
+ciciz6*(uz(i,j,1)+uz(i,j,nz-4))
rz(i,j,nz-2)=0._mytype
tz(i,j,nz-1)=aiciz6*(uz(i,j,nz)+uz(i,j,nz-1))&
+biciz6*(uz(i,j,1)+uz(i,j,nz-2))&
+ciciz6*(uz(i,j,2)+uz(i,j,nz-3))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz)=aiciz6*(uz(i,j,1)+uz(i,j,nz))&
+biciz6*(uz(i,j,2)+uz(i,j,nz-1))&
+ciciz6*(uz(i,j,3)+uz(i,j,nz-2))
rz(i ,j,nz)=ailcaiz6
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*cisz6(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*cisz6(k)
enddo
enddo
enddo
do i=1,nx
do j=1,ny
tz(i,j,nz)=tz(i,j,nz)*ciwz6(nz)
rz(i,j,nz)=rz(i,j,nz)*ciwz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cifz6(k)*tz(i,j,k+1))*ciwz6(k)
rz(i,j,k)=(rz(i,j,k)-cifz6(k)*rz(i,j,k+1))*ciwz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=(tz(i,j,1)-ailcaiz6*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-ailcaiz6*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if ((nclz==1).or.(nclz==2)) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aiciz6*(uz(i,j,2)+uz(i,j,1))&
+biciz6*(uz(i,j,3)+uz(i,j,2))&
+ciciz6*(uz(i,j,4)+uz(i,j,3))
tz(i,j,2)=aiciz6*(uz(i,j,3)+uz(i,j,2))&
+biciz6*(uz(i,j,4)+uz(i,j,1))&
+ciciz6*(uz(i,j,5)+uz(i,j,2))
enddo
enddo
do k=3,nzm-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aiciz6*(uz(i,j,k+1)+uz(i,j,k))&
+biciz6*(uz(i,j,k+2)+uz(i,j,k-1))&
+ciciz6*(uz(i,j,k+3)+uz(i,j,k-2))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm-1)=aiciz6*(uz(i,j,nzm)+uz(i,j,nzm-1))&
+biciz6*(uz(i,j,nz)+uz(i,j,nzm-2))&
+ciciz6*(uz(i,j,nzm)+uz(i,j,nzm-3))
tz(i,j,nzm)=aiciz6*(uz(i,j,nz)+uz(i,j,nzm))&
+biciz6*(uz(i,j,nzm)+uz(i,j,nzm-1))&
+ciciz6*(uz(i,j,nzm-1)+uz(i,j,nzm-2))
enddo
enddo
do k=2,nzm
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*cisz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nzm)=tz(i,j,nzm)*ciwz6(nzm)
enddo
enddo
do k=nzm-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cifz6(k)*tz(i,j,k+1))*ciwz6(k)
enddo
enddo
enddo
endif
endif
return
end subroutine interz6
!********************************************************************
!
subroutine deciz6(tz,uz,rz,sz,cfiz6,csiz6,cwiz6,cfz6,csz6,cwz6,&
nx,ny,nzm,nz,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,nzm,ny,nz,npaire
real(mytype), dimension(nx,ny,nz) :: tz
real(mytype), dimension(nx,ny,nzm) :: uz,rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nz) :: cfiz6,csiz6,cwiz6
real(mytype), dimension(nz) :: cfz6,csz6,cwz6
integer :: i,j,k
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aciz6*(uz(i,j,1)-uz(i,j,nz))&
+bciz6*(uz(i,j,2)-uz(i,j,nz-1))
rz(i,j,1)=-1._mytype
tz(i,j,2)=aciz6*(uz(i,j,2)-uz(i,j,1))&
+bciz6*(uz(i,j,3)-uz(i,j,nz))
rz(i,j,2)=0._mytype
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aciz6*(uz(i,j,k)-uz(i,j,k-1))&
+bciz6*(uz(i,j,k+1)-uz(i,j,k-2))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2))&
+bciz6*(uz(i,j,nz)-uz(i,j,nz-3))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz)=aciz6*(uz(i,j,nz)-uz(i,j,nz-1))&
+bciz6*(uz(i,j,1)-uz(i,j,nz-2))
rz(i,j,nz)=alcaiz6
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*csz6(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*csz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*cwz6(nz)
rz(i,j,nz)=rz(i,j,nz)*cwz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cfz6(k)*tz(i,j,k+1))*cwz6(k)
rz(i,j,k)=(rz(i,j,k)-cfz6(k)*rz(i,j,k+1))*cwz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=(tz(i,j,1)-alcaiz6*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-alcaiz6*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if ((nclz==1).or.(nclz==2)) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=0._mytype
tz(i,j,2)=aciz6*(uz(i,j,2)-uz(i,j,1))&
+bciz6*(uz(i,j,3)-uz(i,j,1))
enddo
enddo
do k=3,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aciz6*(uz(i,j,k)-uz(i,j,k-1))&
+bciz6*(uz(i,j,k+1)-uz(i,j,k-2))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=aciz6*(uz(i,j,nz-1)-uz(i,j,nz-2))&
+bciz6*(uz(i,j,nz-1)-uz(i,j,nz-3))
tz(i,j,nz)=0._mytype
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*csiz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*cwiz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cfiz6(k)*tz(i,j,k+1))*cwiz6(k)
enddo
enddo
enddo
endif
endif
return
end subroutine deciz6
!********************************************************************
!
subroutine interiz6(tz,uz,rz,sz,cifiz6,cisiz6,ciwiz6,cifz6,cisz6,ciwz6,&
nx,ny,nzm,nz,npaire)
!
!********************************************************************
USE param
USE derivZ
implicit none
integer :: nx,ny,nz,nzm,npaire
real(mytype), dimension(nx,ny,nz) :: tz
real(mytype), dimension(nx,ny,nzm) :: uz
real(mytype), dimension(nx,ny,nz) :: rz
real(mytype), dimension(nx,ny) :: sz
real(mytype), dimension(nz) :: cifiz6,cisiz6,ciwiz6
real(mytype), dimension(nz) :: cifz6,cisz6,ciwz6
integer :: i,j,k
if (nclz==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aiciz6*(uz(i,j,1)+uz(i,j,nz))&
+biciz6*(uz(i,j,2)+uz(i,j,nz-1))&
+ciciz6*(uz(i,j,3)+uz(i,j,nz-2))
rz(i,j,1)=-1._mytype
tz(i,j,2)=aiciz6*(uz(i,j,2)+uz(i,j,1))&
+biciz6*(uz(i,j,3)+uz(i,j,nz))&
+ciciz6*(uz(i,j,4)+uz(i,j,nz-1))
rz(i,j,2)=0._mytype
tz(i,j,3)=aiciz6*(uz(i,j,3)+uz(i,j,2))&
+biciz6*(uz(i,j,4)+uz(i,j,1))&
+ciciz6*(uz(i,j,5)+uz(i,j,nz))
rz(i,j,3)=0._mytype
enddo
enddo
do k=4,nz-2
do j=1,ny
do i=1,nx
tz(i,j,k)=aiciz6*(uz(i,j,k)+uz(i,j,k-1))&
+biciz6*(uz(i,j,k+1)+uz(i,j,k-2))&
+ciciz6*(uz(i,j,k+2)+uz(i,j,k-3))
rz(i,j,k)=0._mytype
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-1)=aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2))&
+biciz6*(uz(i,j,nz)+uz(i,j,nz-3))&
+ciciz6*(uz(i,j,1)+uz(i,j,nz-4))
rz(i,j,nz-1)=0._mytype
tz(i,j,nz)=aiciz6*(uz(i,j,nz)+uz(i,j,nz-1))&
+biciz6*(uz(i,j,1)+uz(i,j,nz-2))&
+ciciz6*(uz(i,j,2)+uz(i,j,nz-3))
rz(i,j,nz)=ailcaiz6
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*cisz6(k)
rz(i,j,k)=rz(i,j,k)-rz(i,j,k-1)*cisz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*ciwz6(nz)
rz(i,j,nz)=rz(i,j,nz)*ciwz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cifz6(k)*tz(i,j,k+1))*ciwz6(k)
rz(i,j,k)=(rz(i,j,k)-cifz6(k)*rz(i,j,k+1))*ciwz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
sz(i,j)=(tz(i,j,1)-ailcaiz6*tz(i,j,nz))/&
(1._mytype+rz(i,j,1)-ailcaiz6*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-sz(i,j)*rz(i,j,k)
enddo
enddo
enddo
endif
if ((nclz==1).or.(nclz==2)) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=aiciz6*(uz(i,j,1)+uz(i,j,1))&
+biciz6*(uz(i,j,2)+uz(i,j,2))&
+ciciz6*(uz(i,j,3)+uz(i,j,3))
tz(i,j,2)=aiciz6*(uz(i,j,2)+uz(i,j,1))&
+biciz6*(uz(i,j,3)+uz(i,j,1))&
+ciciz6*(uz(i,j,4)+uz(i,j,2))
tz(i,j,3)=aiciz6*(uz(i,j,3)+uz(i,j,2))&
+biciz6*(uz(i,j,4)+uz(i,j,1))&
+ciciz6*(uz(i,j,5)+uz(i,j,1))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=aiciz6*(uz(i,j,k)+uz(i,j,k-1))&
+biciz6*(uz(i,j,k+1)+uz(i,j,k-2))&
+ciciz6*(uz(i,j,k+2)+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz-2)=aiciz6*(uz(i,j,nz-2)+uz(i,j,nz-3))&
+biciz6*(uz(i,j,nz-1)+uz(i,j,nz-4))&
+ciciz6*(uz(i,j,nz-1)+uz(i,j,nz-5))
tz(i,j,nz-1)=aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-2))&
+biciz6*(uz(i,j,nz-1)+uz(i,j,nz-3))&
+ciciz6*(uz(i,j,nz-2)+uz(i,j,nz-4))
tz(i,j,nz)=aiciz6*(uz(i,j,nz-1)+uz(i,j,nz-1))&
+biciz6*(uz(i,j,nz-2)+uz(i,j,nz-2))&
+ciciz6*(uz(i,j,nz-3)+uz(i,j,nz-3))
enddo
enddo
do k=2,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=tz(i,j,k)-tz(i,j,k-1)*cisiz6(k)
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*ciwiz6(nz)
enddo
enddo
do k=nz-1,1,-1
do j=1,ny
do i=1,nx
tz(i,j,k)=(tz(i,j,k)-cifiz6(k)*tz(i,j,k+1))*ciwiz6(k)
enddo
enddo
enddo
endif
endif
return
end subroutine interiz6
factor.f90 0000644 0001750 0001750 00000003531 13051023554 012564 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! A few utility routines to find factors of integer numbers
subroutine findfactor(num, factors, nfact)
implicit none
integer, intent(IN) :: num
integer, intent(OUT), dimension(*) :: factors
integer, intent(OUT) :: nfact
integer :: i, m
! find the factors <= sqrt(num)
m = int(sqrt(real(num)))
nfact = 1
do i=1,m
if (num/i*i == num) then
factors(nfact) = i
nfact = nfact + 1
end if
end do
nfact = nfact - 1
! derive those > sqrt(num)
if (factors(nfact)**2/=num) then
do i=nfact+1, 2*nfact
factors(i) = num / factors(2*nfact-i+1)
end do
nfact = nfact * 2
else
do i=nfact+1, 2*nfact-1
factors(i) = num / factors(2*nfact-i)
end do
nfact = nfact * 2 - 1
endif
return
end subroutine findfactor
subroutine primefactors(num, factors, nfact)
implicit none
integer, intent(IN) :: num
integer, intent(OUT), dimension(*) :: factors
integer, intent(INOUT) :: nfact
integer :: i, n
i = 2
nfact = 1
n = num
do
if (mod(n,i) == 0) then
factors(nfact) = i
nfact = nfact + 1
n = n / i
else
i = i + 1
end if
if (n == 1) then
nfact = nfact - 1
exit
end if
end do
return
end subroutine primefactors
fft_common_3d.f90 0000644 0001750 0001750 00000015313 13051023554 014024 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! This file contains 3D c2c/r2c/c2r transform subroutines which are
! identical for several FFT engines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D FFT - complex to complex
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_c2c(in, out, isign)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: in
complex(mytype), dimension(:,:,:), intent(OUT) :: out
integer, intent(IN) :: isign
#ifndef OVERWRITE
complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif
if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR. &
format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then
! ===== 1D FFTs in X =====
#ifdef OVERWRITE
call c2c_1m_x(in,isign,ph)
#else
allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
wk1 = in
call c2c_1m_x(wk1,isign,ph)
#endif
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_x_to_y(in,wk2_c2c,ph)
#else
call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif
call c2c_1m_y(wk2_c2c,isign,ph)
else
#ifdef OVERWRITE
call c2c_1m_y(in,isign,ph)
#else
call c2c_1m_y(wk1,isign,ph)
#endif
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_c2c,out,ph)
else
#ifdef OVERWRITE
call transpose_y_to_z(in,out,ph)
#else
call transpose_y_to_z(wk1,out,ph)
#endif
end if
call c2c_1m_z(out,isign,ph)
else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
.OR. &
format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then
! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
call c2c_1m_z(in,isign,ph)
#else
allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
wk1 = in
call c2c_1m_z(wk1,isign,ph)
#endif
! ===== Swap Z --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_z_to_y(in,wk2_c2c,ph)
#else
call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif
call c2c_1m_y(wk2_c2c,isign,ph)
else ! out==wk2_c2c if 1D decomposition
#ifdef OVERWRITE
call transpose_z_to_y(in,out,ph)
#else
call transpose_z_to_y(wk1,out,ph)
#endif
call c2c_1m_y(out,isign,ph)
end if
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_c2c,out,ph)
end if
call c2c_1m_x(out,isign,ph)
end if
return
end subroutine fft_3d_c2c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D forward FFT - real to complex
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_r2c(in_r, out_c)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: in_r
complex(mytype), dimension(:,:,:), intent(OUT) :: out_c
if (format==PHYSICAL_IN_X) then
! ===== 1D FFTs in X =====
call r2c_1m_x(in_r,wk13)
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
call transpose_x_to_y(wk13,wk2_r2c,sp)
call c2c_1m_y(wk2_r2c,-1,sp)
else
call c2c_1m_y(wk13,-1,sp)
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_r2c,out_c,sp)
else
call transpose_y_to_z(wk13,out_c,sp)
end if
call c2c_1m_z(out_c,-1,sp)
else if (format==PHYSICAL_IN_Z) then
! ===== 1D FFTs in Z =====
call r2c_1m_z(in_r,wk13)
! ===== Swap Z --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
call transpose_z_to_y(wk13,wk2_r2c,sp)
call c2c_1m_y(wk2_r2c,-1,sp)
else ! out_c==wk2_r2c if 1D decomposition
call transpose_z_to_y(wk13,out_c,sp)
call c2c_1m_y(out_c,-1,sp)
end if
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_r2c,out_c,sp)
end if
call c2c_1m_x(out_c,-1,sp)
end if
return
end subroutine fft_3d_r2c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D inverse FFT - complex to real
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_c2r(in_c, out_r)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
real(mytype), dimension(:,:,:), intent(OUT) :: out_r
#ifndef OVERWRITE
complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif
if (format==PHYSICAL_IN_X) then
! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
call c2c_1m_z(in_c,1,sp)
#else
allocate(wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
wk1 = in_c
call c2c_1m_z(wk1,1,sp)
#endif
! ===== Swap Z --> Y; 1D FFTs in Y =====
#ifdef OVERWRITE
call transpose_z_to_y(in_c,wk2_r2c,sp)
#else
call transpose_z_to_y(wk1,wk2_r2c,sp)
#endif
call c2c_1m_y(wk2_r2c,1,sp)
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_r2c,wk13,sp)
call c2r_1m_x(wk13,out_r)
else
call c2r_1m_x(wk2_r2c,out_r)
end if
else if (format==PHYSICAL_IN_Z) then
! ===== 1D FFTs in X =====
#ifdef OVERWRITE
call c2c_1m_x(in_c,1,sp)
#else
allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
wk1 = in_c
call c2c_1m_x(wk1,1,sp)
#endif
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_x_to_y(in_c,wk2_r2c,sp)
#else
call transpose_x_to_y(wk1,wk2_r2c,sp)
#endif
call c2c_1m_y(wk2_r2c,1,sp)
else ! in_c==wk2_r2c if 1D decomposition
#ifdef OVERWRITE
call c2c_1m_y(in_c,1,sp)
#else
call c2c_1m_y(wk1,1,sp)
#endif
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_r2c,wk13,sp)
else
#ifdef OVERWRITE
call transpose_y_to_z(in_c,wk13,sp)
#else
call transpose_y_to_z(wk1,wk13,sp)
#endif
end if
call c2r_1m_z(wk13,out_r)
end if
return
end subroutine fft_3d_c2r
fft_common.f90 0000644 0001750 0001750 00000012642 13051023554 013440 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! This file contains common code shared by all FFT engines
integer, parameter, public :: DECOMP_2D_FFT_FORWARD = -1
integer, parameter, public :: DECOMP_2D_FFT_BACKWARD = 1
! Physical space data can be stored in either X-pencil or Z-pencil
integer, parameter, public :: PHYSICAL_IN_X = 1
integer, parameter, public :: PHYSICAL_IN_Z = 3
integer, save :: format ! input X-pencil or Z-pencil
! The libary can only be initialised once
logical, save :: initialised = .false.
! Global size of the FFT
integer, save :: nx_fft, ny_fft, nz_fft
! 2D processor grid
integer, save, dimension(2) :: dims
! Decomposition objects
TYPE(DECOMP_INFO), save :: ph ! physical space
TYPE(DECOMP_INFO), save :: sp ! spectral space
! Workspace to store the intermediate Y-pencil data
! *** TODO: investigate how to use only one workspace array
complex(mytype), allocatable, dimension(:,:,:) :: wk2_c2c, wk2_r2c
complex(mytype), allocatable, dimension(:,:,:) :: wk13
public :: decomp_2d_fft_init, decomp_2d_fft_3d, &
decomp_2d_fft_finalize, decomp_2d_fft_get_size
! Declare generic interfaces to handle different inputs
interface decomp_2d_fft_init
module procedure fft_init_noarg
module procedure fft_init_arg
module procedure fft_init_general
end interface
interface decomp_2d_fft_3d
module procedure fft_3d_c2c
module procedure fft_3d_r2c
module procedure fft_3d_c2r
end interface
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Initialise the FFT module
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_init_noarg
implicit none
call fft_init_arg(PHYSICAL_IN_X) ! default input is X-pencil data
return
end subroutine fft_init_noarg
subroutine fft_init_arg(pencil) ! allow to handle Z-pencil input
implicit none
integer, intent(IN) :: pencil
call fft_init_general(pencil, nx_global, ny_global, nz_global)
return
end subroutine fft_init_arg
! Initialise the FFT library to perform arbitrary size transforms
subroutine fft_init_general(pencil, nx, ny, nz)
implicit none
integer, intent(IN) :: pencil
integer, intent(IN) :: nx, ny, nz
logical, dimension(2) :: dummy_periods
integer, dimension(2) :: dummy_coords
integer :: status, errorcode, ierror
if (initialised) then
errorcode = 4
call decomp_2d_abort(errorcode, &
'FFT library should only be initialised once')
end if
format = pencil
nx_fft = nx
ny_fft = ny
nz_fft = nz
! determine the processor grid in use
call MPI_CART_GET(DECOMP_2D_COMM_CART_X, 2, &
dims, dummy_periods, dummy_coords, ierror)
! for c2r/r2c interface:
! if in physical space, a real array is of size: nx*ny*nz
! in spectral space, the complex array is of size:
! (nx/2+1)*ny*nz, if PHYSICAL_IN_X
! or nx*ny*(nz/2+1), if PHYSICAL_IN_Z
call decomp_info_init(nx, ny, nz, ph)
if (format==PHYSICAL_IN_X) then
call decomp_info_init(nx/2+1, ny, nz, sp)
else if (format==PHYSICAL_IN_Z) then
call decomp_info_init(nx, ny, nz/2+1, sp)
end if
allocate(wk2_c2c(ph%ysz(1),ph%ysz(2),ph%ysz(3)), STAT=status)
allocate(wk2_r2c(sp%ysz(1),sp%ysz(2),sp%ysz(3)), STAT=status)
if (format==PHYSICAL_IN_X) then
allocate(wk13(sp%xsz(1),sp%xsz(2),sp%xsz(3)), STAT=status)
else if (format==PHYSICAL_IN_Z) then
allocate(wk13(sp%zsz(1),sp%zsz(2),sp%zsz(3)), STAT=status)
end if
if (status /= 0) then
errorcode = 3
call decomp_2d_abort(errorcode, &
'Out of memory when initialising FFT')
end if
call init_fft_engine
initialised = .true.
return
end subroutine fft_init_general
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Final clean up
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_2d_fft_finalize
implicit none
call decomp_info_finalize(ph)
call decomp_info_finalize(sp)
deallocate(wk2_c2c, wk2_r2c, wk13)
call finalize_fft_engine
initialised = .false.
return
end subroutine decomp_2d_fft_finalize
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Return the size, starting/ending index of the distributed array
! whose global size is (nx/2+1)*ny*nz, for defining data structures
! in r2c and c2r interfaces
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine decomp_2d_fft_get_size(istart, iend, isize)
implicit none
integer, dimension(3), intent(OUT) :: istart, iend, isize
if (format==PHYSICAL_IN_X) then
istart = sp%zst
iend = sp%zen
isize = sp%zsz
else if (format==PHYSICAL_IN_Z) then
istart = sp%xst
iend = sp%xen
isize = sp%xsz
end if
return
end subroutine decomp_2d_fft_get_size
fft_fftw3.f90 0000644 0001750 0001750 00000050524 13051023554 013202 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! This is the FFTW (version 3.x) implementation of the FFT library
module decomp_2d_fft
use decomp_2d ! 2D decomposition module
implicit none
include "fftw3.f"
private ! Make everything private unless declared public
! engine-specific global variables
integer, save :: plan_type = FFTW_MEASURE
! FFTW plans
! j=1,2,3 corresponds to the 1D FFTs in X,Y,Z direction, respectively
! For c2c transforms:
! use plan(-1,j) for forward transform;
! use plan( 1,j) for backward transform;
! For r2c/c2r transforms:
! use plan(0,j) for r2c transforms;
! use plan(2,j) for c2r transforms;
integer*8, save :: plan(-1:2,3)
! common code used for all engines, including global variables,
! generic interface definitions and several subroutines
#include "fft_common.f90"
! Return a FFTW3 plan for multiple 1D c2c FFTs in X direction
subroutine c2c_1m_x_plan(plan1, decomp, isign)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer, intent(IN) :: isign
complex(mytype), allocatable, dimension(:,:,:) :: a1
allocate(a1(decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft(plan1, 1, decomp%xsz(1), &
decomp%xsz(2)*decomp%xsz(3), a1, decomp%xsz(1), 1, &
decomp%xsz(1), a1, decomp%xsz(1), 1, decomp%xsz(1), &
isign, plan_type)
#else
call sfftw_plan_many_dft(plan1, 1, decomp%xsz(1), &
decomp%xsz(2)*decomp%xsz(3), a1, decomp%xsz(1), 1, &
decomp%xsz(1), a1, decomp%xsz(1), 1, decomp%xsz(1), &
isign, plan_type)
#endif
deallocate(a1)
return
end subroutine c2c_1m_x_plan
! Return a FFTW3 plan for multiple 1D c2c FFTs in Y direction
subroutine c2c_1m_y_plan(plan1, decomp, isign)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer, intent(IN) :: isign
complex(mytype), allocatable, dimension(:,:) :: a1
! Due to memory pattern of 3D arrays, 1D FFTs along Y have to be
! done one Z-plane at a time. So plan for 2D data sets here.
allocate(a1(decomp%ysz(1),decomp%ysz(2)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft(plan1, 1, decomp%ysz(2), decomp%ysz(1), &
a1, decomp%ysz(2), decomp%ysz(1), 1, a1, decomp%ysz(2), &
decomp%ysz(1), 1, isign, plan_type)
#else
call sfftw_plan_many_dft(plan1, 1, decomp%ysz(2), decomp%ysz(1), &
a1, decomp%ysz(2), decomp%ysz(1), 1, a1, decomp%ysz(2), &
decomp%ysz(1), 1, isign, plan_type)
#endif
deallocate(a1)
return
end subroutine c2c_1m_y_plan
! Return a FFTW3 plan for multiple 1D c2c FFTs in Z direction
subroutine c2c_1m_z_plan(plan1, decomp, isign)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer, intent(IN) :: isign
complex(mytype), allocatable, dimension(:,:,:) :: a1
allocate(a1(decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft(plan1, 1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), a1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), 1, a1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), 1, isign, plan_type)
#else
call sfftw_plan_many_dft(plan1, 1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), a1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), 1, a1, decomp%zsz(3), &
decomp%zsz(1)*decomp%zsz(2), 1, isign, plan_type)
#endif
deallocate(a1)
return
end subroutine c2c_1m_z_plan
! Return a FFTW3 plan for multiple 1D r2c FFTs in X direction
subroutine r2c_1m_x_plan(plan1, decomp_ph, decomp_sp)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
real(mytype), allocatable, dimension(:,:,:) :: a1
complex(mytype), allocatable, dimension(:,:,:) :: a2
allocate(a1(decomp_ph%xsz(1),decomp_ph%xsz(2),decomp_ph%xsz(3)))
allocate(a2(decomp_sp%xsz(1),decomp_sp%xsz(2),decomp_sp%xsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft_r2c(plan1, 1, decomp_ph%xsz(1), &
decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_ph%xsz(1), 1, &
decomp_ph%xsz(1), a2, decomp_sp%xsz(1), 1, decomp_sp%xsz(1), &
plan_type)
#else
call sfftw_plan_many_dft_r2c(plan1, 1, decomp_ph%xsz(1), &
decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_ph%xsz(1), 1, &
decomp_ph%xsz(1), a2, decomp_sp%xsz(1), 1, decomp_sp%xsz(1), &
plan_type)
#endif
deallocate(a1,a2)
return
end subroutine r2c_1m_x_plan
! Return a FFTW3 plan for multiple 1D c2r FFTs in X direction
subroutine c2r_1m_x_plan(plan1, decomp_sp, decomp_ph)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
complex(mytype), allocatable, dimension(:,:,:) :: a1
real(mytype), allocatable, dimension(:,:,:) :: a2
allocate(a1(decomp_sp%xsz(1),decomp_sp%xsz(2),decomp_sp%xsz(3)))
allocate(a2(decomp_ph%xsz(1),decomp_ph%xsz(2),decomp_ph%xsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft_c2r(plan1, 1, decomp_ph%xsz(1), &
decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_sp%xsz(1), 1, &
decomp_sp%xsz(1), a2, decomp_ph%xsz(1), 1, decomp_ph%xsz(1), &
plan_type)
#else
call sfftw_plan_many_dft_c2r(plan1, 1, decomp_ph%xsz(1), &
decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_sp%xsz(1), 1, &
decomp_sp%xsz(1), a2, decomp_ph%xsz(1), 1, decomp_ph%xsz(1), &
plan_type)
#endif
deallocate(a1,a2)
return
end subroutine c2r_1m_x_plan
! Return a FFTW3 plan for multiple 1D r2c FFTs in Z direction
subroutine r2c_1m_z_plan(plan1, decomp_ph, decomp_sp)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
real(mytype), allocatable, dimension(:,:,:) :: a1
complex(mytype), allocatable, dimension(:,:,:) :: a2
allocate(a1(decomp_ph%zsz(1),decomp_ph%zsz(2),decomp_ph%zsz(3)))
allocate(a2(decomp_sp%zsz(1),decomp_sp%zsz(2),decomp_sp%zsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft_r2c(plan1, 1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, a2, decomp_sp%zsz(3), &
decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, plan_type)
#else
call sfftw_plan_many_dft_r2c(plan1, 1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, a2, decomp_sp%zsz(3), &
decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, plan_type)
#endif
deallocate(a1,a2)
return
end subroutine r2c_1m_z_plan
! Return a FFTW3 plan for multiple 1D c2r FFTs in Z direction
subroutine c2r_1m_z_plan(plan1, decomp_sp, decomp_ph)
implicit none
integer*8, intent(OUT) :: plan1
TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
complex(mytype), allocatable, dimension(:,:,:) :: a1
real(mytype), allocatable, dimension(:,:,:) :: a2
allocate(a1(decomp_sp%zsz(1),decomp_sp%zsz(2),decomp_sp%zsz(3)))
allocate(a2(decomp_ph%zsz(1),decomp_ph%zsz(2),decomp_ph%zsz(3)))
#ifdef DOUBLE_PREC
call dfftw_plan_many_dft_c2r(plan1, 1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_sp%zsz(3), &
decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, a2, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, plan_type)
#else
call sfftw_plan_many_dft_c2r(plan1, 1, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_sp%zsz(3), &
decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, a2, decomp_ph%zsz(3), &
decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, plan_type)
#endif
deallocate(a1,a2)
return
end subroutine c2r_1m_z_plan
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This routine performs one-time initialisations for the FFT engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine init_fft_engine
implicit none
if (nrank==0) then
write(*,*) ' '
write(*,*) '***** Using the FFTW (version 3.x) engine *****'
write(*,*) ' '
end if
if (format == PHYSICAL_IN_X) then
! For C2C transforms
call c2c_1m_x_plan(plan(-1,1), ph, FFTW_FORWARD )
call c2c_1m_y_plan(plan(-1,2), ph, FFTW_FORWARD )
call c2c_1m_z_plan(plan(-1,3), ph, FFTW_FORWARD )
call c2c_1m_z_plan(plan( 1,3), ph, FFTW_BACKWARD)
call c2c_1m_y_plan(plan( 1,2), ph, FFTW_BACKWARD)
call c2c_1m_x_plan(plan( 1,1), ph, FFTW_BACKWARD)
! For R2C/C2R tranforms
call r2c_1m_x_plan(plan(0,1), ph, sp)
call c2c_1m_y_plan(plan(0,2), sp, FFTW_FORWARD )
call c2c_1m_z_plan(plan(0,3), sp, FFTW_FORWARD )
call c2c_1m_z_plan(plan(2,3), sp, FFTW_BACKWARD)
call c2c_1m_y_plan(plan(2,2), sp, FFTW_BACKWARD)
call c2r_1m_x_plan(plan(2,1), sp, ph)
else if (format == PHYSICAL_IN_Z) then
! For C2C transforms
call c2c_1m_z_plan(plan(-1,3), ph, FFTW_FORWARD )
call c2c_1m_y_plan(plan(-1,2), ph, FFTW_FORWARD )
call c2c_1m_x_plan(plan(-1,1), ph, FFTW_FORWARD )
call c2c_1m_x_plan(plan( 1,1), ph, FFTW_BACKWARD)
call c2c_1m_y_plan(plan( 1,2), ph, FFTW_BACKWARD)
call c2c_1m_z_plan(plan( 1,3), ph, FFTW_BACKWARD)
! For R2C/C2R tranforms
call r2c_1m_z_plan(plan(0,3), ph, sp)
call c2c_1m_y_plan(plan(0,2), sp, FFTW_FORWARD )
call c2c_1m_x_plan(plan(0,1), sp, FFTW_FORWARD )
call c2c_1m_x_plan(plan(2,1), sp, FFTW_BACKWARD)
call c2c_1m_y_plan(plan(2,2), sp, FFTW_BACKWARD)
call c2r_1m_z_plan(plan(2,3), sp, ph)
end if
return
end subroutine init_fft_engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This routine performs one-time finalisations for the FFT engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine finalize_fft_engine
implicit none
integer :: i,j
do j=1,3
do i=-1,2
#ifdef DOUBLE_PREC
call dfftw_destroy_plan(plan(i,j))
#else
call sfftw_destroy_plan(plan(i,j))
#endif
end do
end do
return
end subroutine finalize_fft_engine
! Following routines calculate multiple one-dimensional FFTs to form
! the basis of three-dimensional FFTs.
! c2c transform, multiple 1D FFTs in x direction
subroutine c2c_1m_x(inout, isign, plan1)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
integer*8, intent(IN) :: plan1
#ifdef DOUBLE_PREC
call dfftw_execute_dft(plan1, inout, inout)
#else
call sfftw_execute_dft(plan1, inout, inout)
#endif
return
end subroutine c2c_1m_x
! c2c transform, multiple 1D FFTs in y direction
subroutine c2c_1m_y(inout, isign, plan1)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
integer*8, intent(IN) :: plan1
integer :: k, s3
! transform on one Z-plane at a time
s3 = size(inout,3)
do k=1,s3
#ifdef DOUBLE_PREC
call dfftw_execute_dft(plan1, inout(:,:,k), inout(:,:,k))
#else
call sfftw_execute_dft(plan1, inout(:,:,k), inout(:,:,k))
#endif
end do
return
end subroutine c2c_1m_y
! c2c transform, multiple 1D FFTs in z direction
subroutine c2c_1m_z(inout, isign, plan1)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
integer*8, intent(IN) :: plan1
#ifdef DOUBLE_PREC
call dfftw_execute_dft(plan1, inout, inout)
#else
call sfftw_execute_dft(plan1, inout, inout)
#endif
return
end subroutine c2c_1m_z
! r2c transform, multiple 1D FFTs in x direction
subroutine r2c_1m_x(input, output)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: input
complex(mytype), dimension(:,:,:), intent(OUT) :: output
#ifdef DOUBLE_PREC
call dfftw_execute_dft_r2c(plan(0,1), input, output)
#else
call sfftw_execute_dft_r2c(plan(0,1), input, output)
#endif
return
end subroutine r2c_1m_x
! r2c transform, multiple 1D FFTs in z direction
subroutine r2c_1m_z(input, output)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: input
complex(mytype), dimension(:,:,:), intent(OUT) :: output
#ifdef DOUBLE_PREC
call dfftw_execute_dft_r2c(plan(0,3), input, output)
#else
call sfftw_execute_dft_r2c(plan(0,3), input, output)
#endif
return
end subroutine r2c_1m_z
! c2r transform, multiple 1D FFTs in x direction
subroutine c2r_1m_x(input, output)
implicit none
complex(mytype), dimension(:,:,:), intent(IN) :: input
real(mytype), dimension(:,:,:), intent(OUT) :: output
#ifdef DOUBLE_PREC
call dfftw_execute_dft_c2r(plan(2,1), input, output)
#else
call sfftw_execute_dft_c2r(plan(2,1), input, output)
#endif
return
end subroutine c2r_1m_x
! c2r transform, multiple 1D FFTs in z direction
subroutine c2r_1m_z(input, output)
implicit none
complex(mytype), dimension(:,:,:), intent(IN) :: input
real(mytype), dimension(:,:,:), intent(OUT) :: output
#ifdef DOUBLE_PREC
call dfftw_execute_dft_c2r(plan(2,3), input, output)
#else
call sfftw_execute_dft_c2r(plan(2,3), input, output)
#endif
return
end subroutine c2r_1m_z
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D FFT - complex to complex
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_c2c(in, out, isign)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: in
complex(mytype), dimension(:,:,:), intent(OUT) :: out
integer, intent(IN) :: isign
#ifndef OVERWRITE
complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif
if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR. &
format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then
! ===== 1D FFTs in X =====
#ifdef OVERWRITE
call c2c_1m_x(in,isign,plan(isign,1))
#else
allocate (wk1(ph%xsz(1),ph%xsz(2),ph%xsz(3)))
wk1 = in
call c2c_1m_x(wk1,isign,plan(isign,1))
#endif
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_x_to_y(in,wk2_c2c,ph)
#else
call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif
call c2c_1m_y(wk2_c2c,isign,plan(isign,2))
else
#ifdef OVERWRITE
call c2c_1m_y(in,isign,plan(isign,2))
#else
call c2c_1m_y(wk1,isign,plan(isign,2))
#endif
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_c2c,out,ph)
else
#ifdef OVERWRITE
call transpose_y_to_z(in,out,ph)
#else
call transpose_y_to_z(wk1,out,ph)
#endif
end if
call c2c_1m_z(out,isign,plan(isign,3))
else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
.OR. &
format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then
! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
call c2c_1m_z(in,isign,plan(isign,3))
#else
allocate (wk1(ph%zsz(1),ph%zsz(2),ph%zsz(3)))
wk1 = in
call c2c_1m_z(wk1,isign,plan(isign,3))
#endif
! ===== Swap Z --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_z_to_y(in,wk2_c2c,ph)
#else
call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif
call c2c_1m_y(wk2_c2c,isign,plan(isign,2))
else ! out==wk2_c2c if 1D decomposition
#ifdef OVERWRITE
call transpose_z_to_y(in,out,ph)
#else
call transpose_z_to_y(wk1,out,ph)
#endif
call c2c_1m_y(out,isign,plan(isign,2))
end if
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_c2c,out,ph)
end if
call c2c_1m_x(out,isign,plan(isign,1))
end if
#ifndef OVERWRITE
deallocate (wk1)
#endif
return
end subroutine fft_3d_c2c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D forward FFT - real to complex
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_r2c(in_r, out_c)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: in_r
complex(mytype), dimension(:,:,:), intent(OUT) :: out_c
if (format==PHYSICAL_IN_X) then
! ===== 1D FFTs in X =====
call r2c_1m_x(in_r,wk13)
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
call transpose_x_to_y(wk13,wk2_r2c,sp)
call c2c_1m_y(wk2_r2c,-1,plan(0,2))
else
call c2c_1m_y(wk13,-1,plan(0,2))
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_r2c,out_c,sp)
else
call transpose_y_to_z(wk13,out_c,sp)
end if
call c2c_1m_z(out_c,-1,plan(0,3))
else if (format==PHYSICAL_IN_Z) then
! ===== 1D FFTs in Z =====
call r2c_1m_z(in_r,wk13)
! ===== Swap Z --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
call transpose_z_to_y(wk13,wk2_r2c,sp)
call c2c_1m_y(wk2_r2c,-1,plan(0,2))
else ! out_c==wk2_r2c if 1D decomposition
call transpose_z_to_y(wk13,out_c,sp)
call c2c_1m_y(out_c,-1,plan(0,2))
end if
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_r2c,out_c,sp)
end if
call c2c_1m_x(out_c,-1,plan(0,1))
end if
return
end subroutine fft_3d_r2c
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 3D inverse FFT - complex to real
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fft_3d_c2r(in_c, out_r)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
real(mytype), dimension(:,:,:), intent(OUT) :: out_r
#ifndef OVERWRITE
complex(mytype), allocatable, dimension(:,:,:) :: wk1
#endif
if (format==PHYSICAL_IN_X) then
! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
call c2c_1m_z(in_c,1,plan(2,3))
#else
allocate (wk1(sp%zsz(1),sp%zsz(2),sp%zsz(3)))
wk1 = in_c
call c2c_1m_z(wk1,1,plan(2,3))
#endif
! ===== Swap Z --> Y; 1D FFTs in Y =====
#ifdef OVERWRITE
call transpose_z_to_y(in_c,wk2_r2c,sp)
#else
call transpose_z_to_y(wk1,wk2_r2c,sp)
#endif
call c2c_1m_y(wk2_r2c,1,plan(2,2))
! ===== Swap Y --> X; 1D FFTs in X =====
if (dims(1)>1) then
call transpose_y_to_x(wk2_r2c,wk13,sp)
call c2r_1m_x(wk13,out_r)
else
call c2r_1m_x(wk2_r2c,out_r)
end if
else if (format==PHYSICAL_IN_Z) then
! ===== 1D FFTs in X =====
#ifdef OVERWRITE
call c2c_1m_x(in_c,1,plan(2,1))
#else
allocate(wk1(sp%xsz(1),sp%xsz(2),sp%xsz(3)))
wk1 = in_c
call c2c_1m_x(wk1,1,plan(2,1))
#endif
! ===== Swap X --> Y; 1D FFTs in Y =====
if (dims(1)>1) then
#ifdef OVERWRITE
call transpose_x_to_y(in_c,wk2_r2c,sp)
#else
call transpose_x_to_y(wk1,wk2_r2c,sp)
#endif
call c2c_1m_y(wk2_r2c,1,plan(2,2))
else ! in_c==wk2_r2c if 1D decomposition
#ifdef OVERWRITE
call c2c_1m_y(in_c,1,plan(2,2))
#else
call c2c_1m_y(wk1,1,plan(2,2))
#endif
end if
! ===== Swap Y --> Z; 1D FFTs in Z =====
if (dims(1)>1) then
call transpose_y_to_z(wk2_r2c,wk13,sp)
else
#ifdef OVERWRITE
call transpose_y_to_z(in_c,wk13,sp)
#else
call transpose_y_to_z(wk1,wk13,sp)
#endif
end if
call c2r_1m_z(wk13,out_r)
end if
#ifndef OVERWRITE
deallocate (wk1)
#endif
return
end subroutine fft_3d_c2r
end module decomp_2d_fft
fft_generic.f90 0000644 0001750 0001750 00000017026 13051023554 013565 0 ustar slaizet slaizet !=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2011 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================
! This is the 'generic' implementation of the FFT library
module decomp_2d_fft
use decomp_2d ! 2D decomposition module
use glassman
implicit none
private ! Make everything private unless declared public
! engine-specific global variables
complex(mytype), allocatable, dimension(:) :: buf, scratch
! common code used for all engines, including global variables,
! generic interface definitions and several subroutines
#include "fft_common.f90"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This routine performs one-time initialisations for the FFT engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine init_fft_engine
implicit none
integer :: cbuf_size
if (nrank==0) then
write(*,*) ' '
write(*,*) '***** Using the generic FFT engine *****'
write(*,*) ' '
end if
cbuf_size = max(ph%xsz(1), ph%ysz(2))
cbuf_size = max(cbuf_size, ph%zsz(3))
allocate(buf(cbuf_size))
allocate(scratch(cbuf_size))
return
end subroutine init_fft_engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This routine performs one-time finalisations for the FFT engine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine finalize_fft_engine
implicit none
deallocate(buf,scratch)
return
end subroutine finalize_fft_engine
! Following routines calculate multiple one-dimensional FFTs to form
! the basis of three-dimensional FFTs.
! c2c transform, multiple 1D FFTs in x direction
subroutine c2c_1m_x(inout, isign, decomp)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer :: i,j,k
do k=1,decomp%xsz(3)
do j=1,decomp%xsz(2)
do i=1,decomp%xsz(1)
buf(i) = inout(i,j,k)
end do
call spcfft(buf,decomp%xsz(1),isign,scratch)
do i=1,decomp%xsz(1)
inout(i,j,k) = buf(i)
end do
end do
end do
return
end subroutine c2c_1m_x
! c2c transform, multiple 1D FFTs in y direction
subroutine c2c_1m_y(inout, isign, decomp)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer :: i,j,k
do k=1,decomp%ysz(3)
do i=1,decomp%ysz(1)
do j=1,decomp%ysz(2)
buf(j) = inout(i,j,k)
end do
call spcfft(buf,decomp%ysz(2),isign,scratch)
do j=1,decomp%ysz(2)
inout(i,j,k) = buf(j)
end do
end do
end do
return
end subroutine c2c_1m_y
! c2c transform, multiple 1D FFTs in z direction
subroutine c2c_1m_z(inout, isign, decomp)
implicit none
complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
integer, intent(IN) :: isign
TYPE(DECOMP_INFO), intent(IN) :: decomp
integer :: i,j,k
do j=1,decomp%zsz(2)
do i=1,decomp%zsz(1)
do k=1,decomp%zsz(3)
buf(k) = inout(i,j,k)
end do
call spcfft(buf,decomp%zsz(3),isign,scratch)
do k=1,decomp%zsz(3)
inout(i,j,k) = buf(k)
end do
end do
end do
return
end subroutine c2c_1m_z
! r2c transform, multiple 1D FFTs in x direction
subroutine r2c_1m_x(input, output)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: input
complex(mytype), dimension(:,:,:), intent(OUT) :: output
integer :: i,j,k, s1,s2,s3, d1
s1 = size(input,1)
s2 = size(input,2)
s3 = size(input,3)
d1 = size(output,1)
do k=1,s3
do j=1,s2
! Glassman's FFT is c2c only,
! needing some pre- and post-processing for r2c
! pack real input in complex storage
do i=1,s1
buf(i) = cmplx(input(i,j,k),0._mytype, kind=mytype)
end do
call spcfft(buf,s1,-1,scratch)
! note d1 ~ s1/2+1
! simply drop the redundant part of the complex output
do i=1,d1
output(i,j,k) = buf(i)
end do
end do
end do
return
end subroutine r2c_1m_x
! r2c transform, multiple 1D FFTs in z direction
subroutine r2c_1m_z(input, output)
implicit none
real(mytype), dimension(:,:,:), intent(IN) :: input
complex(mytype), dimension(:,:,:), intent(OUT) :: output
integer :: i,j,k, s1,s2,s3, d3
s1 = size(input,1)
s2 = size(input,2)
s3 = size(input,3)
d3 = size(output,3)
do j=1,s2
do i=1,s1
! Glassman's FFT is c2c only,
! needing some pre- and post-processing for r2c
! pack real input in complex storage
do k=1,s3
buf(k) = cmplx(input(i,j,k),0._mytype, kind=mytype)
end do
call spcfft(buf,s3,-1,scratch)
! note d3 ~ s3/2+1
! simply drop the redundant part of the complex output
do k=1,d3
output(i,j,k) = buf(k)
end do
end do
end do
return
end subroutine r2c_1m_z
! c2r transform, multiple 1D FFTs in x direction
subroutine c2r_1m_x(input, output)
implicit none
complex(mytype), dimension(:,:,:), intent(IN) :: input
real(mytype), dimension(:,:,:), intent(OUT) :: output
integer :: i,j,k, d1,d2,d3
d1 = size(output,1)
d2 = size(output,2)
d3 = size(output,3)
do k=1,d3
do j=1,d2
! Glassman's FFT is c2c only,
! needing some pre- and post-processing for c2r
do i=1,d1/2+1
buf(i) = input(i,j,k)
end do
! expanding to a full-size complex array
! For odd N, the storage is:
! 1, 2, ...... N/2+1 integer division rounded down
! N, ...... N/2+2 => a(i) is conjugate of a(N+2-i)
! For even N, the storage is:
! 1, 2, ...... N/2 , N/2+1
! N, ...... N/2+2 again a(i) conjugate of a(N+2-i)
do i=d1/2+2,d1
buf(i) = conjg(buf(d1+2-i))
end do
call spcfft(buf,d1,1,scratch)
do i=1,d1
! simply drop imaginary part
output(i,j,k) = real(buf(i), kind=mytype)
end do
end do
end do
return
end subroutine c2r_1m_x
! c2r transform, multiple 1D FFTs in z direction
subroutine c2r_1m_z(input, output)
implicit none
complex(mytype), dimension(:,:,:), intent(IN) :: input
real(mytype), dimension(:,:,:), intent(OUT) :: output
integer :: i,j,k, d1,d2,d3
d1 = size(output,1)
d2 = size(output,2)
d3 = size(output,3)
do j=1,d2
do i=1,d1
do k=1,d3/2+1
buf(k) = input(i,j,k)
end do
do k=d3/2+2,d3
buf(k) = conjg(buf(d3+2-k))
end do
call spcfft(buf,d3,1,scratch)
do k=1,d3
output(i,j,k) = real(buf(k), kind=mytype)
end do
end do
end do
return
end subroutine c2r_1m_z
#include "fft_common_3d.f90"
end module decomp_2d_fft
filter.f90 0000644 0001750 0001750 00000151474 13051023554 012605 0 ustar slaizet slaizet !################################################################################
!This file is part of Incompact3d.
!
!Incompact3d
!Copyright (c) 2012 Eric Lamballais and Sylvain Laizet
!eric.lamballais@univ-poitiers.fr / sylvain.laizet@gmail.com
!
! Incompact3d 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.
!
! Incompact3d 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 the code. If not, see .
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
! We kindly request that you cite Incompact3d in your publications and
! presentations. The following citations are suggested:
!
! 1-Laizet S. & Lamballais E., 2009, High-order compact schemes for
! incompressible flows: a simple and efficient method with the quasi-spectral
! accuracy, J. Comp. Phys., vol 228 (15), pp 5989-6015
!
! 2-Laizet S. & Li N., 2011, Incompact3d: a powerful tool to tackle turbulence
! problems with up to 0(10^5) computational cores, Int. J. of Numerical
! Methods in Fluids, vol 67 (11), pp 1735-1757
!################################################################################
!*********************************************************************
!
subroutine filx(tx,ux,rx,sx,vx,fiffx,fifx,ficx,fibx,fibbx,filax,fiz1x,&
fiz2x,nx,ny,nz,npaire)
!
!*********************************************************************
USE param
USE parfiX
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tx,ux,rx
real(mytype), dimension(ny,nz) :: sx,vx
real(mytype), dimension(nx) :: fiffx, fifx,ficx,fibx,fibbx,fiz1x,fiz2x
real(mytype), dimension(nx,2) :: filax
real(mytype) :: xcoef
if (nclx==0) then
do k=1,nz
do j=1,ny
rx(1,j,k)=fiaix*ux(1,j,k)+&
fibix*(ux(2,j,k)+ux(nx,j,k))+&
ficix*(ux(3,j,k)+ux(nx-1,j,k))+&
fidix*(ux(4,j,k)+ux(nx-2,j,k))
rx(2,j,k)=fiaix*ux(2,j,k)+&
fibix*(ux(3,j,k)+ux(1,j,k))+&
ficix*(ux(4,j,k)+ux(nx,j,k))+&
fidix*(ux(5,j,k)+ux(nx-1,j,k))
rx(3,j,k)=fiaix*ux(3,j,k)+&
fibix*(ux(4,j,k)+ux(2,j,k))+&
ficix*(ux(5,j,k)+ux(1,j,k))+&
fidix*(ux(6,j,k)+ux(nx,j,k))
enddo
enddo
do i=4,nx-3
do k=1,nz
do j=1,ny
rx(i,j,k)=fiaix*ux(i,j,k)+&
fibix*(ux(i+1,j,k)+ux(i-1,j,k))+&
ficix*(ux(i+2,j,k)+ux(i-2,j,k))+&
fidix*(ux(i+3,j,k)+ux(i-3,j,k))
enddo
enddo
enddo
do k=1,nz
do j=1,ny
rx(nx,j,k)=fiaix*ux(nx,j,k)+&
fibix*(ux(1,j,k)+ux(nx-1,j,k))+&
ficix*(ux(2,j,k)+ux(nx-2,j,k))+&
fidix*(ux(3,j,k)+ux(nx-3,j,k))
rx(nx-1,j,k)=fiaix*ux(nx-1,j,k)+&
fibix*(ux(nx,j,k)+ux(nx-2,j,k))+&
ficix*(ux(1,j,k)+ux(nx-3,j,k))+&
fidix*(ux(2,j,k)+ux(nx-4,j,k))
rx(nx-2,j,k)=fiaix*ux(nx-2,j,k)+&
fibix*(ux(nx-1,j,k)+ux(nx-3,j,k))+&
ficix*(ux(nx,j,k)+ux(nx-4,j,k))+&
fidix*(ux(1,j,k)+ux(nx-5,j,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx-2
rx(i+1,j,k)=rx(i+1,j,k)-filax(i,1)*rx(i,j,k)
rx(i+2,j,k)=rx(i+2,j,k)-filax(i,2)*rx(i,j,k)
enddo
enddo
enddo
do k=1,nz
do j=1,ny
rx(nx,j,k)=rx(nx,j,k)-filax(nx-1,1)*rx(nx-1,j,k)
enddo
enddo
do k=1,nz
do j=1,ny
rx(nx,j,k)=rx(nx,j,k)*fiffx(nx)
rx(nx-1,j,k)=(rx(nx-1,j,k)-fifx(nx-1)*rx(nx,j,k))*&
fiffx(nx-1)
rx(nx-2,j,k)=(rx(nx-2,j,k)-fifx(nx-2)*rx(nx-1,j,k)-&
ficx(nx-2)*rx(nx,j,k))*fiffx(nx-2)
rx(nx-3,j,k)=(rx(nx-3,j,k)-fifx(nx-3)*rx(nx-2,j,k)-&
ficx(nx-3)*rx(nx-1,j,k)-&
fibx(nx-3)*rx(nx,j,k))*fiffx(nx-3)
enddo
enddo
do k=1,nz
do j=1,ny
do i=nx-4,1,-1
rx(i,j,k)=(rx(i,j,k)-fifx(i)*rx(i+1,j,k)-&
ficx(i)*rx(i+2,j,k)-&
fibx(i)*rx(i+3,j,k)-&
fibbx(i)*rx(i+4,j,k))*fiffx(i)
enddo
enddo
enddo
xcoef=1._mytype/2._mytype
do k=1,nz
do j=1,ny
sx(j,k)=fih1x*(-fibex*rx(1,j,k)+fibex*rx(nx-1,j,k)*xcoef+&
fialx*rx(nx,j,k)*xcoef)+&
fih2x*(fialx*rx(1,j,k)*xcoef+fibex*rx(2,j,k)*xcoef-&
fibex*rx(nx,j,k))
vx(j,k)=fih3x*(-fibex*rx(1,j,k)+fibex*rx(nx-1,j,k)*xcoef+&
fialx*rx(nx,j,k)*xcoef)+&
fih4x*(fialx*rx(1,j,k)*xcoef+fibex*rx(2,j,k)*xcoef-&
fibex*rx(nx,j,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tx(i,j,k)=rx(i,j,k)-fiz1x(i)*sx(j,k)-fiz2x(i)*vx(j,k)
enddo
enddo
enddo
endif
if (nclx==1) then
if (npaire==1) then
do k=1,nz
do j=1,ny
tx(1,j,k)=fiaix*ux(1,j,k)+&
fibix*(ux(2,j,k)+ux(2,j,k))+&
ficix*(ux(3,j,k)+ux(3,j,k))+&
fidix*(ux(4,j,k)+ux(4,j,k))
tx(2,j,k)=fiaix*ux(2,j,k)+&
fibix*(ux(3,j,k)+ux(1,j,k))+&
ficix*(ux(4,j,k)+ux(2,j,k))+&
fidix*(ux(5,j,k)+ux(3,j,k))
tx(3,j,k)=fiaix*ux(3,j,k)+&
fibix*(ux(4,j,k)+ux(2,j,k))+&
ficix*(ux(5,j,k)+ux(1,j,k))+&
fidix*(ux(6,j,k)+ux(2,j,k))
enddo
enddo
do i=4,nx-3
do k=1,nz
do j=1,ny
tx(i,j,k)=fiaix*ux(i,j,k)+&
fibix*(ux(i+1,j,k)+ux(i-1,j,k))+&
ficix*(ux(i+2,j,k)+ux(i-2,j,k))+&
fidix*(ux(i+3,j,k)+ux(i-3,j,k))
enddo
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=fiaix*ux(nx,j,k)+&
fibix*(ux(nx-1,j,k)+ux(nx-1,j,k))+&
ficix*(ux(nx-2,j,k)+ux(nx-2,j,k))+&
fidix*(ux(nx-3,j,k)+ux(nx-3,j,k))
tx(nx-1,j,k)=fiaix*ux(nx-1,j,k)+&
fibix*(ux(nx,j,k)+ux(nx-2,j,k))+&
ficix*(ux(nx-1,j,k)+ux(nx-3,j,k))+&
fidix*(ux(nx-2,j,k)+ux(nx-4,j,k))
tx(nx-2,j,k)=fiaix*ux(nx-2,j,k)+&
fibix*(ux(nx-1,j,k)+ux(nx-3,j,k))+&
ficix*(ux(nx,j,k)+ux(nx-4,j,k))+&
fidix*(ux(nx-1,j,k)+ux(nx-5,j,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx-2
tx(i+1,j,k)=tx(i+1,j,k)-filax(i,1)*tx(i,j,k)
tx(i+2,j,k)=tx(i+2,j,k)-filax(i,2)*tx(i,j,k)
enddo
tx(nx,j,k)=tx(nx,j,k)-filax(nx-1,1)*tx(nx-1,j,k)
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=tx(nx,j,k)*fiffx(nx)
tx(nx-1,j,k)=(tx(nx-1,j,k)-fifx(nx-1)*tx(nx,j,k))*&
fiffx(nx-1)
tx(nx-2,j,k)=(tx(nx-2,j,k)-fifx(nx-2)*tx(nx-1,j,k)-&
ficx(nx-2)*tx(nx,j,k))*fiffx(nx-2)
tx(nx-3,j,k)=(tx(nx-3,j,k)-fifx(nx-3)*tx(nx-2,j,k)-&
ficx(nx-3)*tx(nx-1,j,k)-&
fibx(nx-3)*tx(nx,j,k))*fiffx(nx-3)
do i=nx-4,1,-1
tx(i,j,k)=(tx(i,j,k)-fifx(i)*tx(i+1,j,k)-&
ficx(i)*tx(i+2,j,k)-&
fibx(i)*tx(i+3,j,k)-&
fibbx(i)*tx(i+4,j,k))*fiffx(i)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do j=1,ny
tx(1,j,k)=fiaix*ux(1,j,k)+&
fibix*(ux(2,j,k)-ux(2,j,k))+&
ficix*(ux(3,j,k)-ux(3,j,k))+&
fidix*(ux(4,j,k)-ux(4,j,k))
tx(2,j,k)=fiaix*ux(2,j,k)+&
fibix*(ux(3,j,k)+ux(1,j,k))+&
ficix*(ux(4,j,k)-ux(2,j,k))+&
fidix*(ux(5,j,k)-ux(3,j,k))
tx(3,j,k)=fiaix*ux(3,j,k)+&
fibix*(ux(4,j,k)+ux(2,j,k))+&
ficix*(ux(5,j,k)+ux(1,j,k))+&
fidix*(ux(6,j,k)-ux(2,j,k))
enddo
enddo
do i=4,nx-3
do k=1,nz
do j=1,ny
tx(i,j,k)=fiaix*ux(i,j,k)+&
fibix*(ux(i+1,j,k)+ux(i-1,j,k))+&
ficix*(ux(i+2,j,k)+ux(i-2,j,k))+&
fidix*(ux(i+3,j,k)+ux(i-3,j,k))
enddo
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=fiaix*ux(nx,j,k)+&
fibix*(ux(nx-1,j,k)-ux(nx-1,j,k))+&
ficix*(ux(nx-2,j,k)-ux(nx-2,j,k))+&
fidix*(ux(nx-3,j,k)-ux(nx-3,j,k))
tx(nx-1,j,k)=fiaix*ux(nx-1,j,k)+&
fibix*(ux(nx,j,k)+ux(nx-2,j,k))+&
ficix*(-ux(nx-1,j,k)+ux(nx-3,j,k))+&
fidix*(-ux(nx-2,j,k)+ux(nx-4,j,k))
tx(nx-2,j,k)=fiaix*ux(nx-2,j,k)+&
fibix*(ux(nx-1,j,k)+ux(nx-3,j,k))+&
ficix*(ux(nx,j,k)+ux(nx-4,j,k))+&
fidix*(-ux(nx-1,j,k)+ux(nx-5,j,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx-2
tx(i+1,j,k)=tx(i+1,j,k)-filax(i,1)*tx(i,j,k)
tx(i+2,j,k)=tx(i+2,j,k)-filax(i,2)*tx(i,j,k)
enddo
tx(nx,j,k)=tx(nx,j,k)-filax(nx-1,1)*tx(nx-1,j,k)
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=tx(nx,j,k)*fiffx(nx)
tx(nx-1,j,k)=(tx(nx-1,j,k)-fifx(nx-1)*tx(nx,j,k))*&
fiffx(nx-1)
tx(nx-2,j,k)=(tx(nx-2,j,k)-fifx(nx-2)*tx(nx-1,j,k)-&
ficx(nx-2)*tx(nx,j,k))*fiffx(nx-2)
tx(nx-3,j,k)=(tx(nx-3,j,k)-fifx(nx-3)*tx(nx-2,j,k)-&
ficx(nx-3)*tx(nx-1,j,k)-&
fibx(nx-3)*tx(nx,j,k))*fiffx(nx-3)
do i=nx-4,1,-1
tx(i,j,k)=(tx(i,j,k)-fifx(i)*tx(i+1,j,k)-&
ficx(i)*tx(i+2,j,k)-&
fibx(i)*tx(i+3,j,k)-&
fibbx(i)*tx(i+4,j,k))*fiffx(i)
enddo
enddo
enddo
endif
endif
if (nclx==2) then
do k=1,nz
do j=1,ny
tx(1,j,k)=fia1x*ux(1,j,k)+fib1x*ux(2,j,k)+&
fic1x*ux(3,j,k)+fid1x*ux(4,j,k)+&
fie1x*ux(5,j,k)
tx(2,j,k)=fia2x*ux(2,j,k)+fib2x*ux(1,j,k)+&
fic2x*ux(3,j,k)+fid2x*ux(4,j,k)+&
fie2x*ux(5,j,k)
tx(3,j,k)=fia3x*ux(3,j,k)+fib3x*ux(1,j,k)+&
fic3x*ux(2,j,k)+fid3x*ux(4,j,k)+&
fie3x*ux(5,j,k)
enddo
enddo
do i=4,nx-3
do k=1,nz
do j=1,ny
tx(i,j,k)=fiaix*ux(i,j,k)+&
fibix*(ux(i+1,j,k)+ux(i-1,j,k))+&
ficix*(ux(i+2,j,k)+ux(i-2,j,k))+&
fidix*(ux(i+3,j,k)+ux(i-3,j,k))
enddo
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=fianx*ux(nx,j,k)+fibnx*ux(nx-1,j,k)+&
ficnx*ux(nx-2,j,k)+fidnx*ux(nx-3,j,k)+&
fienx*ux(nx-4,j,k)
tx(nx-1,j,k)=fiamx*ux(nx-1,j,k)+fibmx*ux(nx,j,k)+&
ficmx*ux(nx-2,j,k)+fidmx*ux(nx-3,j,k)+&
fiemx*ux(nx-4,j,k)
tx(nx-2,j,k)=fiapx*ux(nx-2,j,k)+fibpx*ux(nx,j,k)+&
ficpx*ux(nx-1,j,k)+fidpx*ux(nx-3,j,k)+&
fiepx*ux(nx-4,j,k)
enddo
enddo
do i=1,nx-2
do k=1,nz
do j=1,ny
tx(i+1,j,k)=tx(i+1,j,k)-filax(i,1)*tx(i,j,k)
tx(i+2,j,k)=tx(i+2,j,k)-filax(i,2)*tx(i,j,k)
enddo
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=tx(nx,j,k)-filax(nx-1,1)*tx(nx-1,j,k)
enddo
enddo
do k=1,nz
do j=1,ny
tx(nx,j,k)=tx(nx,j,k)*fiffx(nx)
tx(nx-1,j,k)=(tx(nx-1,j,k)-fifx(nx-1)*tx(nx,j,k))*&
fiffx(nx-1)
tx(nx-2,j,k)=(tx(nx-2,j,k)-fifx(nx-2)*tx(nx-1,j,k)-&
ficx(nx-2)*tx(nx,j,k))*fiffx(nx-2)
tx(nx-3,j,k)=(tx(nx-3,j,k)-fifx(nx-3)*tx(nx-2,j,k)-&
ficx(nx-3)*tx(nx-1,j,k)-&
fibx(nx-3)*tx(nx,j,k))*fiffx(nx-3)
enddo
enddo
do i=nx-4,1,-1
do k=1,nz
do j=1,ny
tx(i,j,k)=(tx(i,j,k)-fifx(i)*tx(i+1,j,k)-&
ficx(i)*tx(i+2,j,k)-&
fibx(i)*tx(i+3,j,k)-&
fibbx(i)*tx(i+4,j,k))*fiffx(i)
enddo
enddo
enddo
endif
return
end subroutine filx
!*********************************************************************
!
subroutine fily(ty,uy,ry,sy,vy,fiffy,fify,ficy,fiby,fibby,filay,fiz1y,&
fiz2y,nx,ny,nz,npaire)
!
!*********************************************************************
USE param
USE parfiY
implicit none
integer :: nx,ny,nz,i,j,k,npaire
real(mytype), dimension(nx,ny,nz) :: ty,uy,ry
real(mytype), dimension(nx,nz) :: sy,vy
real(mytype), dimension(ny) :: fiffy,fify,ficy,fiby,fibby,fiz1y,fiz2y
real(mytype), dimension(ny,2) :: filay
real(mytype) :: xcoef
if (ncly==0) then
do k=1,nz
do i=1,nx
ry(i,1,k)=fiaiy*uy(i,1,k)+&
fibiy*(uy(i,2,k)+uy(i,ny,k))+&
ficiy*(uy(i,3,k)+uy(i,ny-1,k))+&
fidiy*(uy(i,4,k)+uy(i,ny-2,k))
ry(i,2,k)=fiaiy*uy(i,2,k)+&
fibiy*(uy(i,3,k)+uy(i,1,k))+&
ficiy*(uy(i,4,k)+uy(i,ny,k))+ &
fidiy*(uy(i,5,k)+uy(i,ny-1,k))
ry(i,3,k)=fiaiy*uy(i,3,k)+&
fibiy*(uy(i,4,k)+uy(i,2,k))+&
ficiy*(uy(i,5,k)+uy(i,1,k))+&
fidiy*(uy(i,6,k)+uy(i,ny,k))
enddo
enddo
do j=4,ny-3
do k=1,nz
do i=1,nx
ry(i,j,k)=fiaiy*uy(i,j,k)+&
fibiy*(uy(i,j+1,k)+uy(i,j-1,k))+&
ficiy*(uy(i,j+2,k)+uy(i,j-2,k))+&
fidiy*(uy(i,j+3,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ry(i,ny,k)=fiaiy*uy(i,ny,k)+&
fibiy*(uy(i,1,k)+uy(i,ny-1,k))+&
ficiy*(uy(i,2,k)+uy(i,ny-2,k))+&
fidiy*(uy(i,3,k)+uy(i,ny-3,k))
ry(i,ny-1,k)=fiaiy*uy(i,ny-1,k)+&
fibiy*(uy(i,ny,k)+uy(i,ny-2,k))+&
ficiy*(uy(i,1,k)+uy(i,ny-3,k))+&
fidiy*(uy(i,2,k)+uy(i,ny-4,k))
ry(i,ny-2,k)=fiaiy*uy(i,ny-2,k)+&
fibiy*(uy(i,ny-1,k)+uy(i,ny-3,k))+&
ficiy*(uy(i,ny,k)+uy(i,ny-4,k))+&
fidiy*(uy(i,1,k)+uy(i,ny-5,k))
enddo
enddo
do k=1,nz
do i=1,nx
do j=1,ny-2
ry(i,j+1,k)=ry(i,j+1,k)-filay(j,1)*ry(i,j,k)
ry(i,j+2,k)=ry(i,j+2,k)-filay(j,2)*ry(i,j,k)
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ry(i,ny,k)=ry(i,ny,k)-filay(ny-1,1)*ry(i,ny-1,k)
enddo
enddo
do k=1,nz
do i=1,nx
ry(i,ny,k)=ry(i,ny,k)*fiffy(ny)
ry(i,ny-1,k)=(ry(i,ny-1,k)-fify(ny-1)*ry(i,ny,k))*&
fiffy(ny-1)
ry(i,ny-2,k)=(ry(i,ny-2,k)-fify(ny-2)*ry(i,ny-1,k)-&
ficy(ny-2)*ry(i,ny,k))*fiffy(ny-2)
ry(i,ny-3,k)=(ry(i,ny-3,k)-fify(ny-3)*ry(i,ny-2,k)-&
ficy(ny-3)*ry(i,ny-1,k)-&
fiby(ny-3)*ry(i,ny,k))*fiffy(ny-3)
enddo
enddo
do k=1,nz
do i=1,nx
do j=ny-4,1,-1
ry(i,j,k)=(ry(i,j,k)-fify(j)*ry(i,j+1,k)-&
ficy(j)*ry(i,j+2,k)-&
fiby(j)*ry(i,j+3,k)-&
fibby(j)*ry(i,j+4,k))*fiffy(j)
enddo
enddo
enddo
xcoef=1._mytype/2._mytype
do k=1,nz
do i=1,nx
sy(i,k)=fih1y*(-fibey*ry(i,1,k)+fibey*ry(i,ny-1,k)*xcoef+&
fialy*ry(i,ny,k)*xcoef)+&
fih2y*(fialy*ry(i,1,k)*xcoef+fibey*ry(i,2,k)*xcoef-&
fibey*ry(i,ny,k))
vy(i,k)=fih3y*(-fibey*ry(i,1,k)+fibey*ry(i,ny-1,k)*xcoef+&
fialy*ry(i,ny,k)*xcoef)+&
fih4y*(fialy*ry(i,1,k)*xcoef+fibey*ry(i,2,k)*xcoef-&
fibey*ry(i,ny,k))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
ty(i,j,k)=ry(i,j,k)-fiz1y(j)*sy(i,k)-fiz2y(j)*vy(i,k)
enddo
enddo
enddo
endif
if (ncly==1) then
if (npaire==1) then
do k=1,nz
do i=1,nx
ty(i,1,k)=fiaiy*uy(i,1,k)+&
fibiy*(uy(i,2,k)+uy(i,2,k))+&
ficiy*(uy(i,3,k)+uy(i,3,k))+&
fidiy*(uy(i,4,k)+uy(i,4,k))
ty(i,2,k)=fiaiy*uy(i,2,k)+&
fibiy*(uy(i,3,k)+uy(i,1,k))+&
ficiy*(uy(i,4,k)+uy(i,2,k))+&
fidiy*(uy(i,5,k)+uy(i,3,k))
ty(i,3,k)=fiaiy*uy(i,3,k)+&
fibiy*(uy(i,4,k)+uy(i,2,k))+&
ficiy*(uy(i,5,k)+uy(i,1,k))+&
fidiy*(uy(i,6,k)+uy(i,2,k))
enddo
enddo
do j=4,ny-3
do k=1,nz
do i=1,nx
ty(i,j,k)=fiaiy*uy(i,j,k)+&
fibiy*(uy(i,j+1,k)+uy(i,j-1,k))+&
ficiy*(uy(i,j+2,k)+uy(i,j-2,k))+&
fidiy*(uy(i,j+3,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=fiaiy*uy(i,ny,k)+&
fibiy*(uy(i,ny-1,k)+uy(i,ny-1,k))+&
ficiy*(uy(i,ny-2,k)+uy(i,ny-2,k))+&
fidiy*(uy(i,ny-3,k)+uy(i,ny-3,k))
ty(i,ny-1,k)=fiaiy*uy(i,ny-1,k)+&
fibiy*(uy(i,ny,k)+uy(i,ny-2,k))+&
ficiy*(uy(i,ny-1,k)+uy(i,ny-3,k))+&
fidiy*(uy(i,ny-2,k)+uy(i,ny-4,k))
ty(i,ny-2,k)=fiaiy*uy(i,ny-2,k)+&
fibiy*(uy(i,ny-1,k)+uy(i,ny-3,k))+&
ficiy*(uy(i,ny,k)+uy(i,ny-4,k))+&
fidiy*(uy(i,ny-1,k)+uy(i,ny-5,k))
enddo
enddo
do k=1,nz
do i=1,nx
do j=1,ny-2
ty(i,j+1,k)=ty(i,j+1,k)-filay(j,1)*ty(i,j,k)
ty(i,j+2,k)=ty(i,j+2,k)-filay(j,2)*ty(i,j,k)
enddo
ty(i,ny,k)=ty(i,ny,k)-filay(ny-1,1)*ty(i,ny-1,k)
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fiffy(ny)
ty(i,ny-1,k)=(ty(i,ny-1,k)-fify(ny-1)*ty(i,ny,k))*&
fiffy(ny-1)
ty(i,ny-2,k)=(ty(i,ny-2,k)-fify(ny-2)*ty(i,ny-1,k)-&
ficy(ny-2)*ty(i,ny,k))*fiffy(ny-2)
ty(i,ny-3,k)=(ty(i,ny-3,k)-fify(ny-3)*ty(i,ny-2,k)-&
ficy(ny-3)*ty(i,ny-1,k)-&
fiby(ny-3)*ty(i,ny,k))*fiffy(ny-3)
do j=ny-4,1,-1
ty(i,j,k)=(ty(i,j,k)-fify(j)*ty(i,j+1,k)-&
ficy(j)*ty(i,j+2,k)-&
fiby(j)*ty(i,j+3,k)-&
fibby(j)*ty(i,j+4,k))*fiffy(j)
enddo
enddo
enddo
endif
if (npaire==0) then
do k=1,nz
do i=1,nx
ty(i,1,k)=fiaiy*uy(i,1,k)+&
fibiy*(uy(i,2,k)-uy(i,2,k))+&
ficiy*(uy(i,3,k)-uy(i,3,k))+&
fidiy*(uy(i,4,k)-uy(i,4,k))
ty(i,2,k)=fiaiy*uy(i,2,k)+&
fibiy*(uy(i,3,k)+uy(i,1,k))+&
ficiy*(uy(i,4,k)-uy(i,2,k))+&
fidiy*(uy(i,5,k)-uy(i,3,k))
ty(i,3,k)=fiaiy*uy(i,3,k)+&
fibiy*(uy(i,4,k)+uy(i,2,k))+&
ficiy*(uy(i,5,k)+uy(i,1,k))+&
fidiy*(uy(i,6,k)-uy(i,2,k))
enddo
enddo
do j=4,ny-3
do k=1,nz
do i=1,nx
ty(i,j,k)=fiaiy*uy(i,j,k)+&
fibiy*(uy(i,j+1,k)+uy(i,j-1,k))+&
ficiy*(uy(i,j+2,k)+uy(i,j-2,k))+&
fidiy*(uy(i,j+3,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=fiaiy*uy(i,ny,k)+&
fibiy*(uy(i,ny-1,k)-uy(i,ny-1,k))+&
ficiy*(uy(i,ny-2,k)-uy(i,ny-2,k))+&
fidiy*(uy(i,ny-3,k)-uy(i,ny-3,k))
ty(i,ny-1,k)=fiaiy*uy(i,ny-1,k)+&
fibiy*(uy(i,ny,k)+uy(i,ny-2,k))+&
ficiy*(-uy(i,ny-1,k)+uy(i,ny-3,k))+&
fidiy*(-uy(i,ny-2,k)+uy(i,ny-4,k))
ty(i,ny-2,k)=fiaiy*uy(i,ny-2,k)+&
fibiy*(uy(i,ny-1,k)+uy(i,ny-3,k))+&
ficiy*(uy(i,ny,k)+uy(i,ny-4,k))+&
fidiy*(-uy(i,ny-1,k)+uy(i,ny-5,k))
enddo
enddo
do k=1,nz
do i=1,nx
do j=1,ny-2
ty(i,j+1,k)=ty(i,j+1,k)-filay(j,1)*ty(i,j,k)
ty(i,j+2,k)=ty(i,j+2,k)-filay(j,2)*ty(i,j,k)
enddo
ty(i,ny,k)=ty(i,ny,k)-filay(ny-1,1)*ty(i,ny-1,k)
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fiffy(ny)
ty(i,ny-1,k)=(ty(i,ny-1,k)-fify(ny-1)*ty(i,ny,k))*&
fiffy(ny-1)
ty(i,ny-2,k)=(ty(i,ny-2,k)-fify(ny-2)*ty(i,ny-1,k)-&
ficy(ny-2)*ty(i,ny,k))*fiffy(ny-2)
ty(i,ny-3,k)=(ty(i,ny-3,k)-fify(ny-3)*ty(i,ny-2,k)-&
ficy(ny-3)*ty(i,ny-1,k)-&
fiby(ny-3)*ty(i,ny,k))*fiffy(ny-3)
do j=ny-4,1,-1
ty(i,j,k)=(ty(i,j,k)-fify(j)*ty(i,j+1,k)-&
ficy(j)*ty(i,j+2,k)-&
fiby(j)*ty(i,j+3,k)-&
fibby(j)*ty(i,j+4,k))*fiffy(j)
enddo
enddo
enddo
endif
endif
if (ncly.eq.2) then
do k=1,nz
do i=1,nx
ty(i,1,k)=fia1y*uy(i,1,k)+fib1y*uy(i,2,k)+&
fic1y*uy(i,3,k)+fid1y*uy(i,4,k)+&
fie1y*uy(i,5,k)
ty(i,2,k)=fia2y*uy(i,2,k)+fib2y*uy(i,1,k)+&
fic2y*uy(i,3,k)+fid2y*uy(i,4,k)+&
fie2y*uy(i,5,k)
ty(i,3,k)=fia3y*uy(i,3,k)+fib3y*uy(i,1,k)+&
fic3y*uy(i,2,k)+fid3y*uy(i,4,k)+&
fie3y*uy(i,5,k)
enddo
enddo
do j=4,ny-3
do k=1,nz
do i=1,nx
ty(i,j,k)=fiaiy*uy(i,j,k)+&
fibiy*(uy(i,j+1,k)+uy(i,j-1,k))+&
ficiy*(uy(i,j+2,k)+uy(i,j-2,k))+&
fidiy*(uy(i,j+3,k)+uy(i,j-3,k))
enddo
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=fiany*uy(i,ny,k)+fibny*uy(i,ny-1,k)+&
ficny*uy(i,ny-2,k)+fidny*uy(i,ny-3,k)+&
fieny*uy(i,ny-4,k)
ty(i,ny-1,k)=fiamy*uy(i,ny-1,k)+fibmy*uy(i,ny,k)+&
ficmy*uy(i,ny-2,k)+fidmy*uy(i,ny-3,k)+&
fiemy*uy(i,ny-4,k)
ty(i,ny-2,k)=fiapy*uy(i,ny-2,k)+fibpy*uy(i,ny,k)+&
ficpy*uy(i,ny-1,k)+fidpy*uy(i,ny-3,k)+&
fiepy*uy(i,ny-4,k)
enddo
enddo
do k=1,nz
do i=1,nx
do j=1,ny-2
ty(i,j+1,k)=ty(i,j+1,k)-filay(j,1)*ty(i,j,k)
ty(i,j+2,k)=ty(i,j+2,k)-filay(j,2)*ty(i,j,k)
enddo
ty(i,ny,k)=ty(i,ny,k)-filay(ny-1,1)*ty(i,ny-1,k)
enddo
enddo
do k=1,nz
do i=1,nx
ty(i,ny,k)=ty(i,ny,k)*fiffy(ny)
ty(i,ny-1,k)=(ty(i,ny-1,k)-fify(ny-1)*ty(i,ny,k))*&
fiffy(ny-1)
ty(i,ny-2,k)=(ty(i,ny-2,k)-fify(ny-2)*ty(i,ny-1,k)-&
ficy(ny-2)*ty(i,ny,k))*fiffy(ny-2)
ty(i,ny-3,k)=(ty(i,ny-3,k)-fify(ny-3)*ty(i,ny-2,k)-&
ficy(ny-3)*ty(i,ny-1,k)-&
fiby(ny-3)*ty(i,ny,k))*fiffy(ny-3)
do j=ny-4,1,-1
ty(i,j,k)=(ty(i,j,k)-fify(j)*ty(i,j+1,k)-&
ficy(j)*ty(i,j+2,k)-&
fiby(j)*ty(i,j+3,k)-&
fibby(j)*ty(i,j+4,k))*fiffy(j)
enddo
enddo
enddo
endif
return
end subroutine fily
!*********************************************************************
!
subroutine filz(tz,uz,rz,sz,vz,fiffz,fifz,ficz,fibz,fibbz,filaz,fiz1z,&
fiz2z,nx,ny,nz,npaire)
!
!*********************************************************************
USE param
USE parfiZ
implicit none
integer :: nx,ny,nz,npaire,i,j,k
real(mytype), dimension(nx,ny,nz) :: tz,uz,rz
real(mytype), dimension(nx,ny) :: sz,vz
real(mytype), dimension(nz) :: fiffz,fifz,ficz,fibz,fibbz,fiz1z,fiz2z
real(mytype), dimension(nz,2) :: filaz
real(mytype) :: xcoef
if (nclz==0) then
do j=1,ny
do i=1,nx
rz(i,j,1)=fiaiz*uz(i,j,1)+&
fibiz*(uz(i,j,2)+uz(i,j,nz))+&
ficiz*(uz(i,j,3)+uz(i,j,nz-1))+&
fidiz*(uz(i,j,4)+uz(i,j,nz-2))
rz(i,j,2)=fiaiz*uz(i,j,2)+&
fibiz*(uz(i,j,3)+uz(i,j,1))+ &
ficiz*(uz(i,j,4)+uz(i,j,nz))+&
fidiz*(uz(i,j,5)+uz(i,j,nz-1))
rz(i,j,3)=fiaiz*uz(i,j,3)+&
fibiz*(uz(i,j,4)+uz(i,j,2))+&
ficiz*(uz(i,j,5)+uz(i,j,1))+&
fidiz*(uz(i,j,6)+uz(i,j,nz))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
rz(i,j,k)=fiaiz*uz(i,j,k)+&
fibiz*(uz(i,j,k+1)+uz(i,j,k-1))+&
ficiz*(uz(i,j,k+2)+uz(i,j,k-2))+&
fidiz*(uz(i,j,k+3)+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
rz(i,j,nz)=fiaiz*uz(i,j,nz)+&
fibiz*(uz(i,j,1)+uz(i,j,nz-1))+&
ficiz*(uz(i,j,2)+uz(i,j,nz-2))+&
fidiz*(uz(i,j,3)+uz(i,j,nz-3))
rz(i,j,nz-1)=fiaiz*uz(i,j,nz-1)+&
fibiz*(uz(i,j,nz)+uz(i,j,nz-2))+&
ficiz*(uz(i,j,1)+uz(i,j,nz-3))+&
fidiz*(uz(i,j,2)+uz(i,j,nz-4))
rz(i,j,nz-2)=fiaiz*uz(i,j,nz-2)+&
fibiz*(uz(i,j,nz-1)+uz(i,j,nz-3))+&
ficiz*(uz(i,j,nz)+uz(i,j,nz-4))+&
fidiz*(uz(i,j,1)+uz(i,j,nz-5))
enddo
enddo
do j=1,ny
do i=1,nx
do k=1,nz-2
rz(i,j,k+1)=rz(i,j,k+1)-filaz(k,1)*rz(i,j,k)
rz(i,j,k+2)=rz(i,j,k+2)-filaz(k,2)*rz(i,j,k)
enddo
rz(i,j,nz)=rz(i,j,nz)-filaz(nz-1,1)*rz(i,j,nz-1)
enddo
enddo
do j=1,ny
do i=1,nx
rz(i,j,nz)=rz(i,j,nz)*fiffz(nz)
rz(i,j,nz-1)=(rz(i,j,nz-1)-fifz(nz-1)*rz(i,j,nz))*&
fiffz(nz-1)
rz(i,j,nz-2)=(rz(i,j,nz-2)-fifz(nz-2)*rz(i,j,nz-1)-&
ficz(nz-2)*rz(i,j,nz))*fiffz(nz-2)
rz(i,j,nz-3)=(rz(i,j,nz-3)-fifz(nz-3)*rz(i,j,nz-2)-&
ficz(nz-3)*rz(i,j,nz-1)-&
fibz(nz-3)*rz(i,j,nz))*fiffz(nz-3)
enddo
enddo
do j=1,ny
do i=1,nx
do k=nz-4,1,-1
rz(i,j,k)=(rz(i,j,k)-fifz(k)*rz(i,j,k+1)-&
ficz(k)*rz(i,j,k+2)-&
fibz(k)*rz(i,j,k+3)-&
fibbz(k)*rz(i,j,k+4))*fiffz(k)
enddo
enddo
enddo
xcoef=1._mytype/2._mytype
do j=1,ny
do i=1,nx
sz(i,j)=fih1z*(-fibez*rz(i,j,1)+fibez*rz(i,j,nz-1)*xcoef+&
fialz*rz(i,j,nz)*xcoef)+&
fih2z*(fialz*rz(i,j,1)*xcoef+fibez*rz(i,j,2)*xcoef-&
fibez*rz(i,j,nz))
vz(i,j)=fih3z*(-fibez*rz(i,j,1)+fibez*rz(i,j,nz-1)*xcoef+&
fialz*rz(i,j,nz)*xcoef)+&
fih4z*(fialz*rz(i,j,1)*xcoef+fibez*rz(i,j,2)*xcoef-&
fibez*rz(i,j,nz))
enddo
enddo
do k=1,nz
do j=1,ny
do i=1,nx
tz(i,j,k)=rz(i,j,k)-fiz1z(k)*sz(i,j)-fiz2z(k)*vz(i,j)
enddo
enddo
enddo
endif
if (nclz==1) then
if (npaire==1) then
do j=1,ny
do i=1,nx
tz(i,j,1)=fiaiz*uz(i,j,1)+&
fibiz*(uz(i,j,2)+uz(i,j,2))+&
ficiz*(uz(i,j,3)+uz(i,j,3))+&
fidiz*(uz(i,j,4)+uz(i,j,4))
tz(i,j,2)=fiaiz*uz(i,j,2)+&
fibiz*(uz(i,j,3)+uz(i,j,1))+&
ficiz*(uz(i,j,4)+uz(i,j,2))+&
fidiz*(uz(i,j,5)+uz(i,j,3))
tz(i,j,3)=fiaiz*uz(i,j,3)+&
fibiz*(uz(i,j,4)+uz(i,j,2))+&
ficiz*(uz(i,j,5)+uz(i,j,1))+&
fidiz*(uz(i,j,6)+uz(i,j,2))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=fiaiz*uz(i,j,k)+&
fibiz*(uz(i,j,k+1)+uz(i,j,k-1))+&
ficiz*(uz(i,j,k+2)+uz(i,j,k-2))+&
fidiz*(uz(i,j,k+3)+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=fiaiz*uz(i,j,nz)+&
fibiz*(uz(i,j,nz-1)+uz(i,j,nz-1))+&
ficiz*(uz(i,j,nz-2)+uz(i,j,nz-2))+&
fidiz*(uz(i,j,nz-3)+uz(i,j,nz-3))
tz(i,j,nz-1)=fiaiz*uz(i,j,nz-1)+&
fibiz*(uz(i,j,nz)+uz(i,j,nz-2))+&
ficiz*(uz(i,j,nz-1)+uz(i,j,nz-3))+&
fidiz*(uz(i,j,nz-2)+uz(i,j,nz-4))
tz(i,j,nz-2)=fiaiz*uz(i,j,nz-2)+&
fibiz*(uz(i,j,nz-1)+uz(i,j,nz-3))+&
ficiz*(uz(i,j,nz)+uz(i,j,nz-4))+&
fidiz*(uz(i,j,nz-1)+uz(i,j,nz-5))
enddo
enddo
do j=1,ny
do i=1,nx
do k=1,nz-2
tz(i,j,k+1)=tz(i,j,k+1)-filaz(k,1)*tz(i,j,k)
tz(i,j,k+2)=tz(i,j,k+2)-filaz(k,2)*tz(i,j,k)
enddo
tz(i,j,nz)=tz(i,j,nz)-filaz(nz-1,1)*tz(i,j,nz-1)
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fiffz(nz)
tz(i,j,nz-1)=(tz(i,j,nz-1)-fifz(nz-1)*tz(i,j,nz))*&
fiffz(nz-1)
tz(i,j,nz-2)=(tz(i,j,nz-2)-fifz(nz-2)*tz(i,j,nz-1)-&
ficz(nz-2)*tz(i,j,nz))*fiffz(nz-2)
tz(i,j,nz-3)=(tz(i,j,nz-3)-fifz(nz-3)*tz(i,j,nz-2)-&
ficz(nz-3)*tz(i,j,nz-1)-&
fibz(nz-3)*tz(i,j,nz))*fiffz(nz-3)
do k=nz-4,1,-1
tz(i,j,k)=(tz(i,j,k)-fifz(k)*tz(i,j,k+1)-&
ficz(k)*tz(i,j,k+2)-&
fibz(k)*tz(i,j,k+3)-&
fibbz(k)*tz(i,j,k+4))*fiffz(k)
enddo
enddo
enddo
endif
if (npaire==0) then
do j=1,ny
do i=1,nx
tz(i,j,1)=fiaiz*uz(i,j,1)+&
fibiz*(uz(i,j,2)-uz(i,j,2))+&
ficiz*(uz(i,j,3)-uz(i,j,3))+&
fidiz*(uz(i,j,4)-uz(i,j,4))
tz(i,j,2)=fiaiz*uz(i,j,2)+&
fibiz*(uz(i,j,3)+uz(i,j,1))+&
ficiz*(uz(i,j,4)-uz(i,j,2))+&
fidiz*(uz(i,j,5)-uz(i,j,3))
tz(i,j,3)=fiaiz*uz(i,j,3)+&
fibiz*(uz(i,j,4)+uz(i,j,2))+&
ficiz*(uz(i,j,5)+uz(i,j,1))+&
fidiz*(uz(i,j,6)-uz(i,j,2))
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=fiaiz*uz(i,j,k)+&
fibiz*(uz(i,j,k+1)+uz(i,j,k-1))+&
ficiz*(uz(i,j,k+2)+uz(i,j,k-2))+&
fidiz*(uz(i,j,k+3)+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=fiaiz*uz(i,j,nz)+&
fibiz*(uz(i,j,nz-1)-uz(i,j,nz-1))+&
ficiz*(uz(i,j,nz-2)-uz(i,j,nz-2))+&
fidiz*(uz(i,j,nz-3)-uz(i,j,nz-3))
tz(i,j,nz-1)=fiaiz*uz(i,j,nz-1)+&
fibiz*(uz(i,j,nz)+uz(i,j,nz-2))+&
ficiz*(-uz(i,j,nz-1)+uz(i,j,nz-3))+&
fidiz*(-uz(i,j,nz-2)+uz(i,j,nz-4))
tz(i,j,nz-2)=fiaiz*uz(i,j,nz-2)+&
fibiz*(uz(i,j,nz-1)+uz(i,j,nz-3))+&
ficiz*(uz(i,j,nz)+uz(i,j,nz-4))+&
fidiz*(-uz(i,j,nz-1)+uz(i,j,nz-5))
enddo
enddo
do j=1,ny
do i=1,nx
do k=1,nz-2
tz(i,j,k+1)=tz(i,j,k+1)-filaz(k,1)*tz(i,j,k)
tz(i,j,k+2)=tz(i,j,k+2)-filaz(k,2)*tz(i,j,k)
enddo
tz(i,j,nz)=tz(i,j,nz)-filaz(nz-1,1)*tz(i,j,nz-1)
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fiffz(nz)
tz(i,j,nz-1)=(tz(i,j,nz-1)-fifz(nz-1)*tz(i,j,nz))*&
fiffz(nz-1)
tz(i,j,nz-2)=(tz(i,j,nz-2)-fifz(nz-2)*tz(i,j,nz-1)-&
ficz(nz-2)*tz(i,j,nz))*fiffz(nz-2)
tz(i,j,nz-3)=(tz(i,j,nz-3)-fifz(nz-3)*tz(i,j,nz-2)-&
ficz(nz-3)*tz(i,j,nz-1)-&
fibz(nz-3)*tz(i,j,nz))*fiffz(nz-3)
do k=nz-4,1,-1
tz(i,j,k)=(tz(i,j,k)-fifz(k)*tz(i,j,k+1)-&
ficz(k)*tz(i,j,k+2)-&
fibz(k)*tz(i,j,k+3)-&
fibbz(k)*tz(i,j,k+4))*fiffz(k)
enddo
enddo
enddo
endif
endif
if (nclz==2) then
do j=1,ny
do i=1,nx
tz(i,j,1)=fia1z*uz(i,j,1)+fib1z*uz(i,j,2)+&
fic1z*uz(i,j,3)+fid1z*uz(i,j,4)+&
fie1z*uz(i,j,5)
tz(i,j,2)=fia2z*uz(i,j,2)+fib2z*uz(i,j,1)+&
fic2z*uz(i,j,3)+fid2z*uz(i,j,4)+&
fie2z*uz(i,j,5)
tz(i,j,3)=fia3z*uz(i,j,3)+fib3z*uz(i,j,1)+&
fic3z*uz(i,j,2)+fid3z*uz(i,j,4)+&
fie3z*uz(i,j,5)
enddo
enddo
do k=4,nz-3
do j=1,ny
do i=1,nx
tz(i,j,k)=fiaiz*uz(i,j,k)+&
fibiz*(uz(i,j,k+1)+uz(i,j,k-1))+&
ficiz*(uz(i,j,k+2)+uz(i,j,k-2))+&
fidiz*(uz(i,j,k+3)+uz(i,j,k-3))
enddo
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=fianz*uz(i,j,nz)+fibnz*uz(i,j,nz-1)+&
ficnz*uz(i,j,nz-2)+fidnz*uz(i,j,nz-3)+&
fienz*uz(i,j,nz-4)
tz(i,j,nz-1)=fiamz*uz(i,j,nz-1)+fibmz*uz(i,j,nz)+&
ficmz*uz(i,j,nz-2)+fidmz*uz(i,j,nz-3)+&
fiemz*uz(i,j,nz-4)
tz(i,j,nz-2)=fiapz*uz(i,j,nz-2)+fibpz*uz(i,j,nz)+&
ficpz*uz(i,j,nz-1)+fidpz*uz(i,j,nz-3)+&
fiepz*uz(i,j,nz-4)
enddo
enddo
do j=1,ny
do i=1,nx
do k=1,nz-2
tz(i,j,k+1)=tz(i,j,k+1)-filaz(k,1)*tz(i,j,k)
tz(i,j,k+2)=tz(i,j,k+2)-filaz(k,2)*tz(i,j,k)
enddo
tz(i,j,nz)=tz(i,j,nz)-filaz(nz-1,1)*tz(i,j,nz-1)
enddo
enddo
do j=1,ny
do i=1,nx
tz(i,j,nz)=tz(i,j,nz)*fiffz(nz)
tz(i,j,nz-1)=(tz(i,j,nz-1)-fifz(nz-1)*tz(i,j,nz))*&
fiffz(nz-1)
tz(i,j,nz-2)=(tz(i,j,nz-2)-fifz(nz-2)*tz(i,j,nz-1)-&
ficz(nz-2)*tz(i,j,nz))*fiffz(nz-2)
tz(i,j,nz-3)=(tz(i,j,nz-3)-fifz(nz-3)*tz(i,j,nz-2)-&
ficz(nz-3)*tz(i,j,nz-1)-&
fibz(nz-3)*tz(i,j,nz))*fiffz(nz-3)
do k=nz-4,1,-1
tz(i,j,k)=(tz(i,j,k)-fifz(k)*tz(i,j,k+1)-&
ficz(k)*tz(i,j,k+2)-&
fibz(k)*tz(i,j,k+3)-&
fibbz(k)*tz(i,j,k+4))*fiffz(k)
enddo
enddo
enddo
endif
return
end subroutine filz
!*********************************************************************
!
subroutine filter()
!
!*********************************************************************
USE param
USE parfiX
USE parfiY
USE parfiZ
USE variables
implicit none
integer :: i,j,k
real(mytype) :: xcoef
call coefficients()
if (nx>1) then
xcoef=1._mytype/2._mytype
if (nclx==0) then
fiffx(1)=0._mytype
fifx(1)=0._mytype
ficx(1)=1._mytype+fibex/xcoef
fibx(1)=fialx
fibbx(1)=fibex
fiffx(2)=0._mytype
fifx(2)=fialx+fialx*xcoef
ficx(2)=1._mytype+fibex*xcoef
fibx(2)=fialx
fibbx(2)=fibex
do i=3,nx-2
fiffx(i)=fibex
fifx(i)=fialx
ficx(i)=1._mytype
fibx(i)=fialx
fibbx(i)=fibex
enddo
fiffx(nx-1)=fibex
fifx(nx-1)=fialx
ficx(nx-1)=1._mytype+fibex*xcoef
fibx(nx-1)=fialx+fialx*xcoef
fibbx(nx-1)=0._mytype
fiffx(nx)=fibex
fifx(nx)=fialx
ficx(nx)=1._mytype+fibex/xcoef
fibx(nx)=0._mytype
fibbx(nx)=0._mytype
endif
if (nclx==1) then
fiffx(1)=0._mytype
fifx(1)=0._mytype
ficx(1)=1._mytype
fibx(1)=fialx+fialx
fibbx(1)=fibex+fibex
fiffx(2)=0._mytype
fifx(2)=fialx
ficx(2)=1._mytype+fibex
fibx(2)=fialx
fibbx(2)=fibex
do i=3,nx-2
fiffx(i)=fibex
fifx(i)=fialx
ficx(i)=1._mytype
fibx(i)=fialx
fibbx(i)=fibex
enddo
fiffx(nx-1)=fibex
fifx(nx-1)=fialx
ficx(nx-1)=1._mytype+fibex
fibx(nx-1)=fialx
fibbx(nx-1)=0._mytype
fiffx(nx)=fibex+fibex
fifx(nx)=fialx+fialx
ficx(nx)=1._mytype
fibx(nx)=0._mytype
fibbx(nx)=0._mytype
do i=1,nx
fiffxp(i)=fiffx(i)
fifxp(i)=fifx(i)
ficxp(i)=ficx(i)
fibxp(i)=fibx(i)
fibbxp(i)=fibbx(i)
enddo
fibx(1)=0._mytype
fibbx(1)=0._mytype
ficx(2)=1._mytype-fibex
ficx(nx-1)=1._mytype-fibex
fifx(nx)=0._mytype
fiffx(nx)=0._mytype
endif
if (nclx==2) then
fiffx(1)=0._mytype
fifx(1)=0._mytype
ficx(1)=1._mytype
fibx(1)=0._mytype
fibbx(1)=0._mytype
fiffx(2)=0._mytype
fifx(2)=0._mytype
ficx(2)=1._mytype
fibx(2)=0._mytype
fibbx(2)=0._mytype
fiffx(3)=0._mytype
fifx(3)=0._mytype
ficx(3)=1._mytype
fibx(3)=0._mytype
fibbx(3)=0._mytype
do i=4,nx-3
fiffx(i)=fibex
fifx(i)=fialx
ficx(i)=1._mytype
fibx(i)=fialx
fibbx(i)=fibex
enddo
fiffx(nx-2)=0._mytype
fifx(nx-2)=0._mytype
ficx(nx-2)=1._mytype
fibx(nx-2)=0._mytype
fibbx(nx-2)=0._mytype
fiffx(nx-1)=0._mytype
fifx(nx-1)=0._mytype
ficx(nx-1)=1._mytype
fibx(nx-1)=0._mytype
fibbx(nx-1)=0._mytype
fiffx(nx)=0._mytype
fifx(nx)=0._mytype
ficx(nx)=1._mytype
fibx(nx)=0._mytype
fibbx(nx)=0._mytype
endif
call prepare_filtre(fiffx,fifx,ficx,fibx,fibbx,filax,nx)
if (nclx==1) then
call prepare_filtre(fiffxp,fifxp,ficxp,fibxp,&
fibbxp,filaxp,nx)
do i=1,nx
fiffxp(i)=1._mytype/fiffxp(i)
enddo
endif
if (nclx==0) then
call cyclix(fiffx,fifx,ficx,fibx,fibbx,&
filax,fiz1x,fiz2x,nx)
endif
do i=1,nx
fiffx(i)=1._mytype/fiffx(i)
enddo
endif
if (ny>1) then
xcoef=1._mytype/2._mytype
if (ncly==0) then
fiffy(1)=0._mytype
fify(1)=0._mytype
ficy(1)=1._mytype+fibey/xcoef
fiby(1)=fialy
fibby(1)=fibey
fiffy(2)=0._mytype
fify(2)=fialy+xcoef*fialy
ficy(2)=1._mytype+xcoef*fibey
fiby(2)=fialy
fibby(2)=fibey
do j=3,ny-2
fiffy(j)=fibey
fify(j)=fialy
ficy(j)=1._mytype
fiby(j)=fialy
fibby(j)=fibey
enddo
fiffy(ny-1)=fibey
fify(ny-1)=fialy
ficy(ny-1)=1._mytype+xcoef*fibey
fiby(ny-1)=fialy+xcoef*fialy
fibby(ny-1)=0._mytype
fiffy(ny)=fibey
fify(ny)=fialy
ficy(ny)=1._mytype+fibey/xcoef
fiby(ny)=0._mytype
fibby(ny)=0._mytype
do j=1,ny
fiffyp(j)=fiffy(j)
fifyp(j)=fify(j)
ficyp(j)=ficy(j)
fibyp(j)=fiby(j)
fibbyp(j)=fibby(j)
enddo
endif
if (ncly==1) then
fiffy(1)=0._mytype
fify(1)=0._mytype
ficy(1)=1._mytype
fiby(1)=fialy+fialy
fibby(1)=fibey+fibey
fiffy(2)=0._mytype
fify(2)=fialy
ficy(2)=1._mytype+fibey
fiby(2)=fialy
fibby(2)=fibey
do j=3,ny-2
fiffy(j)=fibey
fify(j)=fialy
ficy(j)=1._mytype
fiby(j)=fialy
fibby(j)=fibey
enddo
fiffy(ny-1)=fibey
fify(ny-1)=fialy
ficy(ny-1)=1._mytype+fibey
fiby(ny-1)=fialy
fibby(ny-1)=0._mytype
fiffy(ny)=fibey+fibey
fify(ny)=fialy+fialy
ficy(ny)=1._mytype
fiby(ny)=0._mytype
fibby(ny)=0._mytype
do j=1,ny
fiffyp(j)=fiffy(j)
fifyp(j)=fify(j)
ficyp(j)=ficy(j)
fibyp(j)=fiby(j)
fibbyp(j)=fibby(j)
enddo
fiby(1)=0._mytype
fibby(1)=0._mytype
ficy(2)=1._mytype-fibey
ficy(ny-1)=1._mytype-fibey
fify(ny)=0._mytype
fiffy(ny)=0._mytype
endif
if (ncly==2) then
fiffy(1)=0._mytype
fify(1)=0._mytype
ficy(1)=1._mytype
fiby(1)=0._mytype
fibby(1)=0._mytype
fiffy(2)=0._mytype
fify(2)=0._mytype
ficy(2)=1._mytype
fiby(2)=0._mytype
fibby(2)=0._mytype
fiffy(3)=0._mytype
fify(3)=0._mytype
ficy(3)=1._mytype
fiby(3)=0._mytype
fibby(3)=0._mytype
do j=4,ny-3
fiffy(j)=fibey
fify(j)=fialy
ficy(j)=1._mytype
fiby(j)=fialy
fibby(j)=fibey
enddo
fiffy(ny-2)=0._mytype
fify(ny-2)=0._mytype
ficy(ny-2)=1._mytype
fiby(ny-2)=0._mytype
fibby(ny-2)=0._mytype
fiffy(ny-1)=0._mytype
fify(ny-1)=0._mytype
ficy(ny-1)=1._mytype
fiby(ny-1)=0._mytype
fibby(ny-1)=0._mytype
fiffy(ny)=0._mytype
fify(ny)=0._mytype
ficy(ny)=1._mytype
fiby(ny)=0._mytype
fibby(ny)=0._mytype
endif
call prepare_filtre(fiffy,fify,ficy,fiby,fibby,filay,ny)
if (ncly==1) then
call prepare_filtre(fiffyp,fifyp,ficyp,fibyp,&
fibbyp,filayp,ny)
do j=1,ny
fiffyp(j)=1._mytype/fiffyp(j)
enddo
endif
if (ncly==0) then
call cycliy(fiffy,fify,ficy,fiby,fibby,&
filay,fiz1y,fiz2y,ny)
endif
do j=1,ny
fiffy(j)=1._mytype/fiffy(j)
enddo
endif
#ifndef TWOD
xcoef=1._mytype/2._mytype
if (nclz==0) then
fiffz(1)=0._mytype
fifz(1)=0._mytype
ficz(1)=1._mytype+fibez/xcoef
fibz(1)=fialz
fibbz(1)=fibez
fiffz(2)=0._mytype
fifz(2)=fialz+fialz*xcoef
ficz(2)=1._mytype+fibez*xcoef
fibz(2)=fialz
fibbz(2)=fibez
do k=3,nz-2
fiffz(k)=fibez
fifz(k)=fialz
ficz(k)=1._mytype
fibz(k)=fialz
fibbz(k)=fibez
enddo
fiffz(nz-1)=fibez
fifz(nz-1)=fialz
ficz(nz-1)=1._mytype+fibez*xcoef
fibz(nz-1)=fialz+fialz*xcoef
fibbz(nz-1)=0._mytype
fiffz(nz)=fibez
fifz(nz)=fialz
ficz(nz)=1._mytype+fibez/xcoef
fibz(nz)=0._mytype
fibbz(nz)=0._mytype
do k=1,nz
fiffzp(k)=fiffz(k)
fifzp(k)=fifz(k)
ficzp(k)=ficz(k)
fibzp(k)=fibz(k)
fibbzp(k)=fibbz(k)
enddo
endif
if (nclz==1) then
fiffz(1)=0._mytype
fifz(1)=0._mytype
ficz(1)=1._mytype
fibz(1)=fialz+fialz
fibbz(1)=fibez+fibez
fiffz(2)=0._mytype
fifz(2)=fialz
ficz(2)=1._mytype+fibez
fibz(2)=fialz
fibbz(2)=fibez
do k=3,nz-2
fiffz(k)=fibez
fifz(k)=fialz
ficz(k)=1._mytype
fibz(k)=fialz
fibbz(k)=fibez
enddo
fiffz(nz-1)=fibez
fifz(nz-1)=fialz
ficz(nz-1)=1._mytype+fibez
fibz(nz-1)=fialz
fibbz(nz-1)=0._mytype
fiffz(nz)=fibez+fibez
fifz(nz)=fialz+fialz
ficz(nz)=1._mytype
fibz(nz)=0._mytype
fibbz(nz)=0._mytype
do k=1,nz
fiffzp(k)=fiffz(k)
fifzp(k)=fifz(k)
ficzp(k)=ficz(k)
fibzp(k)=fibz(k)
fibbzp(k)=fibbz(k)
enddo
fibz(1)=0._mytype
fibbz(1)=0._mytype
ficz(2)=1._mytype-fibez
ficz(nz-1)=1._mytype-fibez
fifz(nz)=0._mytype
fiffz(nz)=0._mytype
endif
if (nclz==2) then
fiffz(1)=0._mytype
fifz(1)=0._mytype
ficz(1)=1._mytype
fibz(1)=0._mytype
fibbz(1)=0._mytype
fiffz(2)=0._mytype
fifz(2)=0._mytype
ficz(2)=1._mytype
fibz(2)=0._mytype
fibbz(2)=0._mytype
fiffz(3)=0._mytype
fifz(3)=0._mytype
ficz(3)=1._mytype
fibz(3)=0._mytype
fibbz(3)=0._mytype
do k=4,nz-3
fiffz(k)=fibez
fifz(k)=fialz
ficz(k)=1._mytype
fibz(k)=fialz
fibbz(k)=fibez
enddo
fiffz(nz-2)=0._mytype
fifz(nz-2)=0._mytype
ficz(nz-2)=1._mytype
fibz(nz-2)=0._mytype
fibbz(nz-2)=0._mytype
fiffz(nz-1)=0._mytype
fifz(nz-1)=0._mytype
ficz(nz-1)=1._mytype
fibz(nz-1)=0._mytype
fibbz(nz-1)=0._mytype
fiffz(nz)=0._mytype
fifz(nz)=0._mytype
ficz(nz)=1._mytype
fibz(nz)=0._mytype
fibbz(nz)=0._mytype
endif
call prepare_filtre(fiffz,fifz,ficz,fibz,fibbz,&
filaz,nz)
if (nclz==1) then
call prepare_filtre(fiffzp,fifzp,ficzp,fibzp,&
fibbzp,filazp,nz)
do k=1,nz
fiffzp(k)=1._mytype/fiffzp(k)
enddo
endif
if (nclz==0) then
call cycliz(fiffz,fifz,ficz,fibz,fibbz,&
filaz,fiz1z,fiz2z,nz)
endif
do k=1,nz
fiffz(k)=1._mytype/fiffz(k)
enddo
#endif
return
end subroutine filter
!*********************************************************************
!
subroutine prepare_filtre(aff,af,a,ab,abb,al,n)
!
!*********************************************************************
use decomp_2d, only : mytype
implicit none
integer :: n ,i,j,k,l
real(mytype), dimension(n) :: aff,af,a,ab,abb
real(mytype), dimension(n,2) :: al
real(mytype) :: tiny, dum
!*********************************************************************
tiny=1.E-10_mytype
aff(1)=a(1)
af(1)=ab(1)
a(1)=abb(1)
ab(1)=0._mytype
abb(1)=0._mytype
aff(2)=af(2)
af(2)=a(2)
a(2)=ab(2)
ab(2)=abb(2)
abb(2)=0._mytype
l=2
do k=1,n
dum=aff(k)
i=k
if (l