From 4de8a61a0e72787ec6d86715dad78baaac245cc0 Mon Sep 17 00:00:00 2001 From: ignis Date: Wed, 16 Apr 2014 15:17:00 +0900 Subject: [PATCH] Original HIT Source --- .gitignore | 5 + Makefile | 123 +++ Makefile_Orig | 115 ++ RANDu.f | 54 + README | 165 +++ begin_new.f90 | 34 + begin_restart.f90 | 88 ++ dealias_all.f90 | 35 + get_file_ext.f90 | 11 + init_scalars.f90 | 383 +++++++ init_velocity.f90 | 295 ++++++ io_write_4.f90 | 92 ++ m_fields.f90 | 414 ++++++++ m_filter_xfftw.f90 | 289 +++++ m_force.f90 | 185 ++++ m_io.f90 | 53 + m_les.f90 | 2396 ++++++++++++++++++++++++++++++++++++++++++ m_openmpi.f90 | 250 +++++ m_parameters.f90 | 515 +++++++++ m_particles.f90 | 1512 ++++++++++++++++++++++++++ m_rand_knuth.f90 | 155 +++ m_stats.f90 | 445 ++++++++ m_timing.f90 | 75 ++ m_work.f90 | 149 +++ main.f90 | 356 +++++++ my_dt.f90 | 34 + my_exit.f90 | 123 +++ pressure.f90 | 96 ++ restart_io.f90 | 506 +++++++++ rhs_scalars.f90 | 594 +++++++++++ rhs_velocity.f90 | 553 ++++++++++ velocity_rescale.f90 | 159 +++ write_tmp4.f90 | 73 ++ x_fftw.f90 | 1286 +++++++++++++++++++++++ 34 files changed, 11618 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 Makefile_Orig create mode 100644 RANDu.f create mode 100644 README create mode 100644 begin_new.f90 create mode 100644 begin_restart.f90 create mode 100644 dealias_all.f90 create mode 100644 get_file_ext.f90 create mode 100644 init_scalars.f90 create mode 100644 init_velocity.f90 create mode 100644 io_write_4.f90 create mode 100644 m_fields.f90 create mode 100644 m_filter_xfftw.f90 create mode 100644 m_force.f90 create mode 100644 m_io.f90 create mode 100644 m_les.f90 create mode 100644 m_openmpi.f90 create mode 100644 m_parameters.f90 create mode 100644 m_particles.f90 create mode 100644 m_rand_knuth.f90 create mode 100644 m_stats.f90 create mode 100644 m_timing.f90 create mode 100644 m_work.f90 create mode 100644 main.f90 create mode 100644 my_dt.f90 create mode 100644 my_exit.f90 create mode 100644 pressure.f90 create mode 100644 restart_io.f90 create mode 100644 rhs_scalars.f90 create mode 100644 rhs_velocity.f90 create mode 100644 velocity_rescale.f90 create mode 100644 write_tmp4.f90 create mode 100644 x_fftw.f90 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..42075a6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.[oa] +*.mod +*.x +scripts/* +tags diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..41e1ddc --- /dev/null +++ b/Makefile @@ -0,0 +1,123 @@ +# Makefile with logic in it. For different hosts runs different things + +# Define the correct flags and compilers + +MPIF90 = blah + +ifeq ($(HOSTNAME), ace2-1.postech.ac.kr) + FFTW_HOME = ../libs/fftw-3.2.2/lib + MPIF90 = mpif90 + FCFLAGS = -i8 -r8 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_HOME)/include + LDFLAGS = -i8 -r8 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib -lfftw3 -lm + FCFLAGS_F77 = -Mextend +endif + +# Franklin cluster, NERSC +ifeq ($(NERSC_HOST), franklin) + MPIF90 = ftn + + FCFLAGS = -target=linux -i8 -r8 -O4 -c + LDFLAGS = -target=linux -i8 -r8 -O4 -lfftw3 + FCFLAGS_F77 = -Mextend +endif + +# Hopper cluster, NERSC +ifeq ($(NERSC_HOST), hopper) + MPIF90 = ftn + + FCFLAGS = -target=linux -i8 -r8 -O4 -c + LDFLAGS = -target=linux -i8 -r8 -O4 -lfftw3 + FCFLAGS_F77 = -Mextend +endif + +# Yellowrail cluster, LANL +ifeq ($(HOSTNAME), yr-fe1.lanl.gov) + MPIF90 = mpif90 + + FCFLAGS = -i8 -r8 -O4 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_INCLUDE) + LDFLAGS = -i8 -r8 -O4 -lfftw3 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib +endif + +# Coyote cluster, LANL +ifeq ($(HOSTNAME), cy-c2.lanl.gov) + MPIF90 = mpif90 + FCFLAGS = -i8 -r8 -O4 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_INCLUDE) + LDFLAGS = -i8 -r8 -O4 -lfftw3 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib +endif + +# Linux Cluster, CMU +ifeq ($(HOSTNAME), karman.me.cmu.edu) + FFTW_HOME = ../libs/fftw-3.2.2/lib + MPIF90 = mpif90 + FCFLAGS = -i8 -r8 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_HOME)/include + LDFLAGS = -i8 -r8 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib -lfftw3 -lm + FCFLAGS_F77 = -Mextend + +endif + +# sparrow.stanford.edu, Mac OS X box +ifeq ($(HOSTNAME), sparrow.stanford.edu) + MPIF90 = mpif90 + FCFLAGS = -fdefault-real-8 -fdefault-integer-8 -finit-integer=0 -finit-real=zero -c + FCFLAGS_F77 = -ffixed-form -ffixed-line-length-none + FCFLAGS_F90 = -ffree-form -ffree-line-length-none + LDFLAGS = -fdefault-real-8 -fdefault-integer-8 -finit-integer=0 -finit-real=zero -lmpi -lmpi -lfftw3 -lm +endif + +# Program name +PROG = hit3d.x + +# Modules +MODULES = m_openmpi.o\ + m_io.o\ + m_parameters.o\ + m_work.o\ + m_fields.o\ + m_timing.o\ + x_fftw.o\ + m_filter_xfftw.o\ + m_particles.o\ + m_stats.o\ + m_force.o\ + m_rand_knuth.o\ + m_les.o\ + RANDu.o + +# Objects +OBJ = main.o\ + begin_new.o\ + begin_restart.o\ + dealias_all.o\ + get_file_ext.o\ + init_velocity.o\ + init_scalars.o\ + io_write_4.o\ + my_dt.o\ + my_exit.o\ + pressure.o\ + restart_io.o\ + rhs_velocity.o\ + rhs_scalars.o\ + velocity_rescale.o\ + write_tmp4.o + + +# ------------------------------------------------------- +# link + +$(PROG): $(MODULES) $(OBJ) + $(MPIF90) $(MODULES) $(OBJ) -o $(PROG) $(LDFLAGS) +# ------------------------------------------------------- +# compile + +$(OBJ): $(MODULES) + +%.o: %.f + $(MPIF90) $(FCFLAGS) $(FCFLAGS_F77) $< + +%.o: %.f90 + $(MPIF90) $(FCFLAGS) $< + +clean: + rm *.o *.mod $(PROG) + diff --git a/Makefile_Orig b/Makefile_Orig new file mode 100644 index 0000000..07f9495 --- /dev/null +++ b/Makefile_Orig @@ -0,0 +1,115 @@ +# Makefile with logic in it. For different hosts runs different things + +# Define the correct flags and compilers + +MPIF90 = blah + +# Franklin cluster, NERSC +ifeq ($(NERSC_HOST), franklin) + MPIF90 = ftn + + FCFLAGS = -target=linux -i8 -r8 -O4 -c + LDFLAGS = -target=linux -i8 -r8 -O4 -lfftw3 + FCFLAGS_F77 = -Mextend +endif + +# Hopper cluster, NERSC +ifeq ($(NERSC_HOST), hopper) + MPIF90 = ftn + + FCFLAGS = -target=linux -i8 -r8 -O4 -c + LDFLAGS = -target=linux -i8 -r8 -O4 -lfftw3 + FCFLAGS_F77 = -Mextend +endif + +# Yellowrail cluster, LANL +ifeq ($(HOSTNAME), yr-fe1.lanl.gov) + MPIF90 = mpif90 + + FCFLAGS = -i8 -r8 -O4 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_INCLUDE) + LDFLAGS = -i8 -r8 -O4 -lfftw3 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib +endif + +# Coyote cluster, LANL +ifeq ($(HOSTNAME), cy-c2.lanl.gov) + MPIF90 = mpif90 + FCFLAGS = -i8 -r8 -O4 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_INCLUDE) + LDFLAGS = -i8 -r8 -O4 -lfftw3 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib +endif + +# WCR cluster, Stanford +ifeq ($(HOSTNAME), glacial.stanford.edu) + FFTW_HOME = /home/chumakov/packages/fftw-3.2/pgi + MPIF90 = mpif90 + FCFLAGS = -i8 -r8 -c $(MPI_COMPILE_FLAGS) -I$(FFTW_HOME)/include + LDFLAGS = -i8 -r8 $(MPI_LD_FLAGS) -L$(FFTW_HOME)/lib -lfftw3 -lm + FCFLAGS_F77 = -Mextend + +endif + +# sparrow.stanford.edu, Mac OS X box +ifeq ($(HOSTNAME), sparrow.stanford.edu) + MPIF90 = mpif90 + FCFLAGS = -fdefault-real-8 -fdefault-integer-8 -finit-integer=0 -finit-real=zero -c + FCFLAGS_F77 = -ffixed-form -ffixed-line-length-none + FCFLAGS_F90 = -ffree-form -ffree-line-length-none + LDFLAGS = -fdefault-real-8 -fdefault-integer-8 -finit-integer=0 -finit-real=zero -lmpi -lmpi -lfftw3 -lm +endif + +# Program name +PROG = hit3d.x + +# Modules +MODULES = m_openmpi.o\ + m_io.o\ + m_parameters.o\ + m_work.o\ + m_fields.o\ + m_timing.o\ + x_fftw.o\ + m_filter_xfftw.o\ + m_particles.o\ + m_stats.o\ + m_force.o\ + m_rand_knuth.o\ + m_les.o\ + RANDu.o + +# Objects +OBJ = main.o\ + begin_new.o\ + begin_restart.o\ + dealias_all.o\ + get_file_ext.o\ + init_velocity.o\ + init_scalars.o\ + io_write_4.o\ + my_dt.o\ + my_exit.o\ + pressure.o\ + restart_io.o\ + rhs_velocity.o\ + rhs_scalars.o\ + velocity_rescale.o\ + write_tmp4.o + + +# ------------------------------------------------------- +# link + +$(PROG): $(MODULES) $(OBJ) + $(MPIF90) $(MODULES) $(OBJ) -o $(PROG) $(LDFLAGS) +# ------------------------------------------------------- +# compile + +$(OBJ): $(MODULES) + +%.o: %.f + $(MPIF90) $(FCFLAGS) $(FCFLAGS_F77) $< + +%.o: %.f90 + $(MPIF90) $(FCFLAGS) $< + +clean: + rm *.o *.mod $(PROG) + diff --git a/RANDu.f b/RANDu.f new file mode 100644 index 0000000..1bbc58b --- /dev/null +++ b/RANDu.f @@ -0,0 +1,54 @@ + module RANDu +c.. + implicit none + + real*8 :: rseed + +c.. +c double precision random +c.. + contains +c---------------------------------------------------- + function random(idum3) +c.. +c.. initialize with idum<0; Then keep idum>0 unchanged for the same +c.. sequence +c.. + integer idum,im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv + double precision random,am,eps,rnmx,idum3 + parameter (im1=2147483563,im2=2147483399,am=1./im1,imm1=im1-1, + + ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=12211, + + ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2e-7,rnmx=1.0-eps) + integer idum2,j,k,iv(ntab),iy +c.. + save iv,iy,idum2 + data idum2/123456789/, iv/ntab*0/, iy/0/ +c.. + idum=nint(idum3/987) + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do 11 j=ntab+8,1,-1 + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0) idum=idum+im1 + if(j.le.ntab) iv(j)=idum + 11 continue + endif +c.. start here when not initializing + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if (idum.lt.0) idum=idum+im1 + k=idum2/iq2 + idum2=ia2*(idum2-k*iq2)-k*ir2 + if (idum2.lt.0) idum2=idum2+im2 + j=1+iy/ndiv + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1) iy=iy+imm1 + random=min(am*iy,rnmx) +c.. + return + end function random +c-------------------------------------------------- + end module RANDu diff --git a/README b/README new file mode 100644 index 0000000..564e834 --- /dev/null +++ b/README @@ -0,0 +1,165 @@ +-------------------------------------------------------------------------------- +GENERAL +-------------------------------------------------------------------------------- +HIT3DP is a pseudospectral DNS code, that is, it performs direct numerical +simulation of incompressible isotripic homogeneous turbulence with or without +forcing. The code has capability of carrying passive scalars, Lagrangian +particles and Large Eddy Simulation + + +-------------------------------------------------------------------------------- +EXTRA PACKAGES +-------------------------------------------------------------------------------- +The code is written in Fortran 90 and uses the two open libraries: +- Open-MPI (www.open-mpi.org) +- FFTW3 (www.fftw.org) + +-------------------------------------------------------------------------------- +LICENSING +-------------------------------------------------------------------------------- +The code is distributed under the terms of GNU GPLv3 license. You can read +the full text of the license at http://www.gnu.org/licenses/gpl.html + +Copyright (C) 2006-2010 Sergei Chumakov, Natalia Vladimirova, Misha Stepanov + + +-------------------------------------------------------------------------------- +COMPILING THE CODE +-------------------------------------------------------------------------------- +First, edit the Makefile: +- add a section that corresponds to the name of your machine. Ideally it should + be a wrapper from your MPI implementation. +- define the name of the F90 compiler +- define FCFLAGS and LDFLAGS. They should include the include directories, the + flags that link FFTW3 and MPI implementation. + +Run "gmake". + +-------------------------------------------------------------------------------- +RUNNING THE CODE +-------------------------------------------------------------------------------- +The directory "scripts" provides some examples of the batch job submission files. + +The directory "scripts" contains the following files: + +00_example.in a sample input file + +snapshot.gp a Gnuplot instruction file that creates two plots that + can get attached to the notification emails + +coyote.sub Running script for the Coyote cluster at LANL +wcr.sub Example script for WCR cluster at Center for Turbuience Research + at Stanford University + +-------------------------------------------------------------------------------- +THE INPUT FILE +-------------------------------------------------------------------------------- +NX,NY,NZ Number of grid points in one dimension. The grid will be NX x NY x NZ. + The physical dimensions will be 2*pi x 2*pi x 2*pi + +ITMIN The timestep number of the restart file. The restart files have names + such as "test__this.64.123456". Here, "test__this" is the run name, + "64" signifies that the file is written with double precision and + "123456" is the timestep number. If the ITMIN is set to 0, the + subroutine that defines the initial conditionis for the flow is called. + +ITMAX The maximum number of timesteps in the simulation. + +IPRNT1 How often to generate the statistics. + +IPRNT2 How often to write restart files + +IWRITE4 How often to write the real*4 files that are used for post-processing. + +TMAX The runtime of the simulation (not the wallclocok time) + +TRESCALE The time at which to rescale the velocity. This is used in decaying + simulations when we want to establish some correlations first and + then rescale the velocity field so it has higher kinetic energy. + +TSCALAR When to start moving the passive scalars. + +flow_type Parameter that switches the flow type + 0 - decaying turbulence + 1 - forced turbulence + +RE The local Reynolds number (1/nu, where nu is viscosity) + +DT The timestep. + If DT is negative, then the timestep is fixed to be (-DT) + If DT is positive, the timestep is found from the stability + criteria for the time-stepping scheme that is used. + +ISPCV1 Initial spectrum type (see init_velocity.f90) +mv1 initial infrared exponent in the spectrum +wm0v1 initial peak wavenumber in the spectrum + + +force_type The type of the forcing that is applied for the case of + forced turbulence. + 1 - forcing from Michaels PRL paper (PRL #79(18) p.3411) + So far no other forcing has been implemented + +KFMAX The upper bound for the forcing band in the Fourier space. + +FAMP The magnitude of the forcing (usually set to 0.5) + +det_rand The parameter that switches the random generation for the + random seeds for the code. + DEFUNCTIONAL. In the current version of the code, the seeds for the + random number generator are fixed and are taken from the input file. + The fixed seeds have the effect of producing the initial data that + looks similar for different resolutions (the large features of + initial flow in 32^3 simulation will look similar to the large features + of a 1024^3 simulation if the seeds are the same). + +RN1, RN2, RN3 - random number seeds + + +DEALIAS The parameter that switches between the dealiasing algorithms. + 0 - the standard 3/2-rule (or 2/3 rule). Faster computations, but + fewer modes. + 1 - the phase shift combined with truncation. This retains much more + modes than the 2/3-rule, while increasing the computations 60% or so. + The most economical mode for DNS in terms of flops per the number of + Fourier modes in the resulting data. + +np The number of Lagrangian particles + +* particle tracking mechanism: + 0 - trilinear interpolations + 1 - 4-point cubic interpolation + +time_p time in the simulation when to release the particles in the flow + +particle_filter_size + The particles can be advected by fully resolved field or by locally averaged + field. The filter size determines the size of the filter that is applied + to the velocity field before computing the particles' velocities. + +les_model The LES model. See m_les.f90 for list of the current models. + +NUMS The number of passive scalars to carry around + +The last section contains the parameters of the passive scalars. Each scalar +must have the type, Schmidt number, infrared exponent, peak wavenumber and +reaction rate. + +TYPE: +0 The scalar that is forced by the mean gradient. +1-9 The initial conditions for the scalar are generated using Fourier space. + 1: Exponential spectrum + 2: von Karman spectrum + 3: double-delta PDF +>10 The initial conditions for the scalar are generated in the real space. + 11: single slab of the scalar. + 12: two slabs of the scalar + 13: 1-D sinusoidal wave of the scalar + + +The reaction rate parameter is defunctional in this version of the code. + +-------------------------------------------------------------------------------- +ANY QUESTIONS? +-------------------------------------------------------------------------------- +email Sergei Chumakov at chumakov@stanford.edu diff --git a/begin_new.f90 b/begin_new.f90 new file mode 100644 index 0000000..a11bf47 --- /dev/null +++ b/begin_new.f90 @@ -0,0 +1,34 @@ +subroutine begin_new + + use m_openmpi + use m_parameters + use m_fields + use m_stats + implicit none + + + ! defining time + TIME = zip + + ! deciding if we advance scalars or not + if (TSCALAR.le.zip .and. n_scalars.gt.0) int_scalars = .true. + + ! defining the iteration number + ITIME = 0 + file_ext = '000000' + + + + if (task.eq.'hydro') then + call init_velocity + if (n_scalars.gt.0) call init_scalars + call io_write_4 + end if + + if (task_split) then + call fields_to_stats + if (task.eq.'stats') call stat_main + end if + + return +end subroutine begin_new diff --git a/begin_restart.f90 b/begin_restart.f90 new file mode 100644 index 0000000..4fecbd4 --- /dev/null +++ b/begin_restart.f90 @@ -0,0 +1,88 @@ +subroutine begin_restart + + use m_parameters + use m_particles + use m_fields + use m_timing + implicit none + + real*8, allocatable :: zhopa(:,:,:,:) + integer :: i + + + write(out,"(70('='))") + write(out,*) ' RESTART ' + write(out,"(70('='))") + call flush(out) + + ITIME = ITMIN + call get_file_ext + + ! reading the restart file + if (task.eq.'hydro') call restart_read_parallel + + ! broadcasting the current simulation time from the restart file + call MPI_BCAST(time,1,MPI_REAL8,0,MPI_COMM_WORLD,mpi_err) + + ! redefining the timestep. + ! the code uses Adams-Bashforth time-stepping scheme, + ! which is 2nd order accurate in time. After the restart, thefirst + ! timestep is done using a simple Euler scheme (1st order in time). + ! To help maintain any sensible accuracy, we need to start with + ! the timestep which is smaller than the last. + if (variable_dt) then + dt = half * dt + call MPI_BCAST(dt,1,MPI_REAL8,0,MPI_COMM_WORLD,mpi_err) + write(out,*) "Making the timestep smaller: ",dt + call flush(out) + end if + + +!!$!================================================================================ +!!$! Checking the parallel read speed (reading 100 times) +!!$! Currently the speedup factor from using parallel read is about 2.5 +!!$!================================================================================ +!!$ if(task.eq.'hydro') then +!!$ call m_timing_check +!!$ write(out,*) 'Start! ',cpu_min,cpu_sec +!!$ do i = 1,200 +!!$ call restart_read! _parallel +!!$ end do +!!$ call m_timing_check +!!$ write(out,*) 'Finish!',cpu_min,cpu_sec +!!$ +!!$ end if +!!$ call MPI_BARRIER(MPI_COMM_WORLD, mpi_err) +!!$ stop 'checking the restart read speed' +!!$ +!!$!================================================================================ +!!$! Checking the accuracy of the parallel read +!!$! (reading parallel first, then serial and comparing) +!!$!================================================================================ +! if (task.eq.'hydro') then +! +! call restart_read_parallel +! +! allocate(zhopa(nx+2,ny,nz,3+n_scalars), stat=ierr) +! if (ierr.ne.0) stop 'cannot allocate zhopa' +! zhopa = zip +! zhopa = fields +! +! call restart_read +! +! print "(10e15.6)",maxval(abs(zhopa-fields)) +! end if +! call MPI_BARRIER(MPI_COMM_WORLD, mpi_err) +! stop 'checking the restart read' +!!$!================================================================================ + + ! deciding whether we advance scalars or not + if (n_scalars.gt.0 .and. time.gt.TSCALAR) then + int_scalars = .true. + write(out,"('Advancing ',i3,' scalars.')") n_scalars + end if + + if (task.eq.'parts') call particles_init + + return +end subroutine begin_restart diff --git a/dealias_all.f90 b/dealias_all.f90 new file mode 100644 index 0000000..ab1220e --- /dev/null +++ b/dealias_all.f90 @@ -0,0 +1,35 @@ +subroutine dealias_all + + use m_parameters + use m_fields + use x_fftw + implicit none + + integer :: i,j,k + real*8 :: akmax + + ! "2/3-rule". For good explanation, see the following paper: + ! R.S.Rogallo, "Numerical Exoeriments in Homogeneous Turbuelnce" + ! NASA Technical Memorandum, NASA 1981. + ! Or contact authors of the code, they should have a PDF copy somewhere. + ! + ! truncating all the modes in which at least one component of the k-vector + ! has magnitude that is larger than N/3 + + akmax = real(kmax,8) + + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + if (abs(akx(i)) .gt. akmax .or. & + abs(aky(k)) .gt. akmax .or. & + abs(akz(j)) .gt. akmax) then + fields(i,j,k,1:3+n_scalars) = zip + end if + + end do + end do + end do + + return +end subroutine dealias_all diff --git a/get_file_ext.f90 b/get_file_ext.f90 new file mode 100644 index 0000000..483063b --- /dev/null +++ b/get_file_ext.f90 @@ -0,0 +1,11 @@ +!================================================================================ +!================================================================================ + subroutine get_file_ext + use m_parameters, only : ITIME + use m_io, only : file_ext + implicit none + + write(file_ext,"(i6.6)") itime + return + end subroutine get_file_ext + diff --git a/init_scalars.f90 b/init_scalars.f90 new file mode 100644 index 0000000..09c49d5 --- /dev/null +++ b/init_scalars.f90 @@ -0,0 +1,383 @@ +!================================================================================ +!================================================================================ +! Initialization of passive scalars +!================================================================================ + +subroutine init_scalars + + use m_parameters + use m_io + use m_fields + use x_fftw, only : ialias + + implicit none + + integer :: n_scalar, i, j, k + + write(out,*) 'Generating scalars' + call flush(out) + + do n_scalar = 1,n_scalars + call init_scalar(n_scalar) + end do + + write(out,*) "Generated the scalars." + call flush(out) + + ! now making sure that the scalars do not have any high + ! Fourier harmonics by zeroing out everything that has a wavenumber + ! that potentially can produce aliasing + do k = 1, nz + do j = 1, ny + do i = 1, nx+2 + if (ialias(i,j,k).gt.0) fields(i,j,k,4:3+n_scalars) = zip + end do + end do + end do + + return + +end subroutine init_scalars + +!================================================================================ +!================================================================================ + +subroutine init_scalar(n_scalar) + + use m_parameters + use m_io + use m_fields + + implicit none + + integer :: n_scalar, ic_type, sc_type + + write(out,*) 'Generating scalar #', n_scalar + call flush(out) + + sc_type = scalar_type(n_scalar) + ic_type = sc_type - (sc_type/100)*100 + + if (ic_type.eq.0) then + ! gradient source - no need for initial conditions + ! thus making the initial scalar field zero + write(out,*) "The scalar type = 0, nothing to generate" + call flush(out) + fields(:,:,:,n_scalar+3) = zip + + elseif (ic_type.lt.10) then + ! if the last two digits of the scalar type are less than 10, + ! the scalar initial conditions are generated based on the + ! particular spectrum of the scalar + call init_scalar_spectrum(n_scalar) + + else + ! if the last two digits are bigger than 10, the scalar is generated + ! in physical space and then transformed in the Fourier space + call init_scalar_space(n_scalar) + + end if + return +end subroutine init_scalar +!================================================================================ +!================================================================================ +subroutine init_scalar_spectrum(n_scalar) +!================================================================================ + + use m_openmpi + use m_parameters + use m_io + use m_fields + use m_work + use x_fftw + use m_rand_knuth + use RANDu + + implicit none + + integer :: i, j, k, n, n_scalar + integer *8 :: i8 + + real*8, allocatable :: e_spec(:), e_spec1(:), rr(:) + integer *8, allocatable :: hits(:), hits1(:) + + integer :: n_shell + real*8 :: sc_rad1, sc_rad2 + + real*8 :: wmag, wmag2, ratio, fac, fac2 + +!-------------------------------------------------------------------------------- + write(out,*) " Generating scalar # ",n_scalar + call flush(out) + + ! Initializing the random sequence with the seed RN2 + fac = random(-RN2) + + ! allocate work arrays + allocate( e_spec(kmax), e_spec1(kmax), hits(kmax), hits1(kmax), & + rr(nx+2), stat=ierr) + + ! bringing the processors to their own places in the random sequence + ! ("2" is there because we're generating two random number fields + ! for each scalar field + ! using i8 because it's int*8 + do i8 = 1,myid*(nx+2)*ny*nz*2 + fac = random(RN2) + end do + + ! now filling the arrays wrk1, wrk2 + do n = 1,2 + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + wrk(i,j,k,n) = random(RN2) + end do + end do + end do + end do + + ! bringing the random numbers to the same + ! point in the sequence again + do i8 = 1,(numprocs-myid-1)*(nx+2)*ny*nz*2 + fac = random(RN2) + end do + + ! making random array with Gaussian PDF + ! out of the two arrays that we generated + wrk(:,:,:,3) = sqrt(-two*log(wrk(:,:,:,1))) * sin(TWO_PI*wrk(:,:,:,2)) + + ! go to Fourier space + call xFFT3d(1,3) + +!------------------------------------------------------------------------------- +! Calculating the scalar spectrum +!------------------------------------------------------------------------------- + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + e_spec1 = zip + e_spec = zip + hits = 0 + hits1 = 0 + + ! assembling the scalar energy in each shell and number of hits in each shell + do k = 1,nz + do j = 1,ny + do i = 1,nx + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + fac2 = fac * wrk(i,j,k,3)**2 + if (akx(i).eq.0.d0) fac2 = fac2 * 0.5d0 + e_spec1(n_shell) = e_spec1(n_shell) + fac2 + end if + end do + end do + end do + + ! reducing the number of hits and energy to two arrays on master node + count = kmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + ! broadcasting the spectrum + count = kmax + call MPI_BCAST(e_spec,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + +!------------------------------------------------------------------------------- +! Now make the spectrum to be as desired +!------------------------------------------------------------------------------- + ! first, define the desired spectrum + do k = 1,kmax + + wmag = real(k, 8) + ratio = wmag / peak_wavenum_sc(n_scalar) + + if (scalar_type(n_scalar).eq.0) then + ! Plain Kolmogorov spectrum + e_spec1(k) = wmag**(-5.d0/3.d0) + + else if (scalar_type(n_scalar).eq.1 .or. scalar_type(n_scalar).eq.3) then + ! Exponential spectrum + e_spec1(k) = ratio**3 / peak_wavenum_sc(n_scalar) * exp(-3.0D0*ratio) + + else if (scalar_type(n_scalar).eq.2) then + ! Von Karman spectrum + fac = two * PI * ratio + e_spec1(k) = fac**4 / (one + fac**2)**3 + + else + write(out,*) "INIT_SCALARS: WRONG INITIAL SPECTRUM TYPE: ",scalar_type(n_scalar) + call flush(out) + stop + + end if + end do + + ! normalize it so it has the unit total energy + e_spec1 = e_spec1 / sum(e_spec1(1:kmax)) + + ! now go over all Fourier shells and multiply the velocities in a shell by + ! the sqrt of ratio of the resired to the current spectrum + fields(:,:,:,3+n_scalar) = zip + + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax .and. e_spec(n_shell) .gt. zip) then + fields(i,j,k,3+n_scalar) = wrk(i,j,k,3) * sqrt(e_spec1(n_shell)/e_spec(n_shell)) + else + fields(i,j,k,3+n_scalar) = zip + end if + + end do + end do + end do + +!------------------------------------------------------------------------------- +! Creating scalars with double-delta PDF +!------------------------------------------------------------------------------- + + if (scalar_type(n_scalar).eq.3) then + wrk(:,:,:,0) = fields(:,:,:,3+n_scalar) + call xFFT3d(-1,0) + + ! making it double-delta (0.9 and -0.9) + wrk(:,:,:,0) = sign(one,wrk(:,:,:,0)) * 0.9d0 + call xFFT3d(1,0) + + ! smoothing it by zeroing out high harmonics + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .eq. 0 .or. n_shell .ge. kmax*2/3) then + wrk(i,j,k,0) = zip + end if + end do + end do + end do + fields(:,:,:,3+n_scalar) = wrk(:,:,:,0) + + end if + + ! deallocate work arrays + deallocate(e_spec, e_spec1, rr, hits, hits1, stat=ierr) + + return +end subroutine init_scalar_spectrum + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +subroutine init_scalar_space(n_scalar) +!================================================================================ + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: i, k, n_scalar, sc_type, ic_type, nfi + real*8 :: zloc, sctmp, h, xx + + nfi = 3 + n_scalar + + write(out,*) " Generating scalar # ", n_scalar + call flush(out) + + sc_type = scalar_type(n_scalar) + ic_type = sc_type - (sc_type/100)*100 + + select case (ic_type) + +!--------------------------------------------------- +! single slab of the scalar +!--------------------------------------------------- + case(11) + + ! how much to smear out the interface + ! the minimum interface length is set to 2*dz + ! the maximum is set to 2*PI/(peak wavenumber for the scalar, taken from + ! the .in file) + h = max(2.*dz, two*PI/peak_wavenum_sc(n_scalar)) + + ! creating array of scalar + do k = 1,nz + zloc = dble(myid*nz + k-1) * dz + sctmp = tanh((zloc-PI*0.5)/h) - tanh((zloc-PI*1.5)/h) - one + wrk(:,:,k,0) = sctmp + end do + + ! FFT of the scalar + call xFFT3d(1,0) + + ! putting it into the scalar array + fields(:,:,:, 3+n_scalar) = wrk(:,:,:,0) + if (iammaster) fields(1,1,1,3+n_scalar) = zip + +!--------------------------------------------------- +! two slabs of the scalar +!--------------------------------------------------- + case(12) + + write(out,*) "-- Double-slab scalar in real space" + call flush(out) + + ! how much to smear out the interface + h = max(8.*dz, PI/8.d0) + + ! creating array of scalar + do i = 1,nx + xx = dble(i-1) * dx + sctmp = tanh((xx-PI*0.25)/h) - tanh((xx-PI*0.75)/h) + tanh((xx-PI*1.25)/h) - tanh((xx-PI*1.75)/h) + wrk(i,:,:,0) = sctmp - one + ! now it is between -1 and 1 + end do + + ! FFT of the scalar + call xFFT3d(1,0) + + ! putting it into the scalar array + fields(:,:,:, 3+n_scalar) = wrk(:,:,:,0) + + ! making sure that the mean is ero + if (iammaster) fields(1,1,1,3+n_scalar) = zip + +!--------------------------------------------------- +! N slabs of the scalar +! actually more like N sinusoidal waves +!--------------------------------------------------- + case(13) + write(out,*) "-- Multi-slab scalar in real space" + call flush(out) + + ! making sure that we can support the desired numberof waves with our FFT + peak_wavenum_sc(n_scalar) = min(peak_wavenum_sc(n_scalar),real(nx/8)) + + ! definition of initial scalar + fields(:,:,:,nfi) = zip + do i = 1, nx + fields(i,:,:,nfi) = sin(peak_wavenum_sc(n_scalar) * dx * real(i-1)) + end do + call xFFT3d_fields(1,nfi) + + + case default + write(out,*) "INIT_SCALARS: UNEXPECTED SCALAR TYPE: ", scalar_type(n_scalar) + call flush(out) + stop + end select + + write(out,*) "Initialized the scalars." + call flush(out) + + return + +end subroutine init_scalar_space diff --git a/init_velocity.f90 b/init_velocity.f90 new file mode 100644 index 0000000..45df2b3 --- /dev/null +++ b/init_velocity.f90 @@ -0,0 +1,295 @@ +subroutine init_velocity + + use m_openmpi + use m_parameters + use m_io + use m_fields + use m_work + use x_fftw + use m_rand_knuth + use RANDu + + implicit none + + integer :: i, j, k, n + integer*8 :: seed1, seed2, i8, j8, k8 + + integer :: time_array(8) + + + real, allocatable :: rr(:) + real*8, allocatable :: e_spec(:), e_spec1(:) + integer *8, allocatable :: hits(:), hits1(:) + + integer :: n_shell + real*8 :: sc_rad1, sc_rad2 + + real*8 :: wmag, wmag2, ratio, fac, fac2 + + +!-------------------------------------------------------------------------------- +! First, if it's a Taylor-Green vortex, then initialize and quit +!-------------------------------------------------------------------------------- + if (isp_type .eq. -1) then + call init_velocity_taylor_green + return + end if + + +!================================================================================ + allocate( e_spec(kmax), e_spec1(kmax), rr(nx+2), hits(kmax), hits1(kmax), stat=ierr) + if (ierr.ne.0) stop "cannot allocate the init_velocity arrays" + + + + write(out,*) 'generating random velocities' + call flush(out) + + +!------------------------------------------------------------------------------- +! Generate the velocities +!------------------------------------------------------------------------------- + + ! initialize the random number sequence by the seed from the first processor + if (myid.eq.0) call system_clock(seed1,seed2) + if (myid.eq.0) then + call date_and_time(values=time_array) + seed1 = time_array(8) + end if + count = 1 + call MPI_BCAST(seed1,count,MPI_INTEGER8,0,MPI_COMM_TASK,mpi_err) + +!!$ seed1 = 23498675 +!!$ call rand_knuth_init(seed1) +!!$ write(out,*) 'seed1 = ',seed1 +!!$ call flush(out) + + seed1 = RN1 + write(out,*) "RANDOM SEED FOR VELOCITIES = ", seed1 + call flush(out) + rseed = real(seed1,8) + fac = random(-rseed) + + + + + ! bringing the processors to their own places in the random sequence + ! ("6" is there because we're generating six fields + ! using seed1 because it's int*8 + +!!$ write(out,*) "Will scroll down to my initial position", myid*ny*nz*6 +!!$ call flush(out) + +!!$ do i = 1,myid*ny*nz*6 +!!$ call rand_knuth(rr,nx+2) +!!$ end do + + do i8 = 1,myid*(nx+2)*ny*nz*6 + fac = random(rseed) + end do + +!!$ write(out,*) "Scrolled." +!!$ call flush(out) + + ! now filling the arrays wrk1...wrk6 + do n = 1,6 + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + wrk(i,j,k,n) = random(rseed) + end do + end do + end do + end do + + ! just in case, bringing the random numbers to the same + ! point in the sequence again + do seed1 = 1,int((numprocs-myid-1)*(nx+2)*ny*nz*6,8) + fac = random(rseed) + end do + + ! making three random arrays with Gaussian PDF + ! out of the six arrays that we generated + wrk(:,:,:,1:3) = sqrt(-two*log(wrk(:,:,:,1:3))) * sin(TWO_PI*wrk(:,:,:,4:6)) + + ! --- Making three arrays that have Gaussian PDF and the incompressibility property + + ! go to Fourier space + do n = 1,3 + call xFFT3d(1,n) + end do + + ! assemble the arrays in wrk4..6, only the wavenumbers below kmax + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + n_shell = nint(sqrt(akx(i)**2 + aky(k)**2 + akz(j)**2)) + + + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + + wrk(i ,j,k,4) = - (aky(k)*wrk(i+1,j,k,3) - akz(j)*wrk(i+1,j,k,2)) + wrk(i+1,j,k,4) = aky(k)*wrk(i ,j,k,3) - akz(j)*wrk(i ,j,k,2) + + wrk(i ,j,k,5) = - (akz(j)*wrk(i+1,j,k,1) - akx(i+1)*wrk(i+1,j,k,3)) + wrk(i+1,j,k,5) = akz(j)*wrk(i ,j,k,1) - akx(i )*wrk(i ,j,k,3) + + wrk(i ,j,k,6) = - (akx(i+1)*wrk(i+1,j,k,2) - aky(k)*wrk(i+1,j,k,1)) + wrk(i+1,j,k,6) = akx(i )*wrk(i ,j,k,2) - aky(k)*wrk(i ,j,k,1) + + else + wrk(i:i+1,j,k,4:6) = zip + end if + + end do + end do + end do + + fields(:,:,:,1:3) = wrk(:,:,:,4:6) + +!------------------------------------------------------------------------------- +! Making the spectrum to be what it should +!------------------------------------------------------------------------------- + + + ! --- first get the energy spectrum (copied from m_stat.f90) + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + e_spec1 = zip + e_spec = zip + hits = 0 + hits1 = 0 + + ! assembling the total energy in each shell and number of hits in each shell + do k = 1,nz + do j = 1,ny + do i = 1,nx + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + fac2 = fac * (fields(i,j,k,1)**2 + fields(i,j,k,2)**2 + fields(i,j,k,3)**2) + if (akx(i).eq.0.d0) fac2 = fac2 * 0.5d0 + e_spec1(n_shell) = e_spec1(n_shell) + fac2 + end if + + end do + end do + end do + + ! reducing the number of hits and energy to two arrays on master node + count = kmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + count = kmax + call MPI_BCAST(e_spec,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + +!------------------------------------------------------------------------------- +! Now make the spectrum to be as desired +!------------------------------------------------------------------------------- + + ! first, define the desired spectrum + do k = 1,kmax + + wmag = real(k, 8) + ratio = wmag / peak_wavenum + + if (isp_type.eq.0) then + ! Plain Kolmogorov spectrum + e_spec1(k) = wmag**(-5.d0/3.d0) + + else if (isp_type.eq.1) then + ! Exponential spectrum + e_spec1(k) = ratio**3 / peak_wavenum * exp(-3.0D0*ratio) + + else if (isp_type.eq.3) then + ! Von Karman spectrum + fac = two * PI * ratio + e_spec1(k) = fac**4 / (one + fac**2)**3 + + else + write(out,*) "ERROR: WRONG INITIAL SPECTRUM TYPE: ",isp_type + call flush(out) + stop + + end if + end do + +! normalize it so it has the unit total energy + e_spec1 = e_spec1 / sum(e_spec1(1:kmax)) + + ! now go over all Fourier shells and multiply the velocities in a shell by + ! the sqrt of ratio of the resired to the current spectrum + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax .and. e_spec(n_shell) .gt. zip) then + fields(i,j,k,1:3) = fields(i,j,k,1:3) * sqrt(e_spec1(n_shell)/e_spec(n_shell)) + else + fields(i,j,k,1:3) = zip + end if + + end do + end do + end do + + write(out,*) "Generated the velocities." + call flush(out) + + + ! deallocate work arrays + deallocate(e_spec, e_spec1, rr, hits, hits1, stat=ierr) + return +end subroutine init_velocity + + +!================================================================================ +! Initialize the velocities with Taylor-Green vortex +!================================================================================ +subroutine init_velocity_taylor_green + + use m_openmpi + use m_parameters + use m_io + use m_fields + use m_work + use x_fftw + + implicit none + + logical :: verbose = .true. + + integer :: i, j, k, n + real*8 :: xx, yy, zz + + if (verbose) write(out,*) " --- Initial velocity field is Taylor-Green vortex" + if (verbose) call flush(out) + + do k = 1, nz + zz = real(nz*myid + k - 1, 8) * dz + do j = 1, ny + yy = real(j-1, 8) * dy + do i = 1, nx + xx = real(i-1,8) *dx + wrk(i,j,k,1) = sin(xx) * cos(yy) * cos(zz) + wrk(i,j,k,2) = - cos(xx) * sin(yy) * cos(zz) + wrk(i,j,k,3) = zip + end do + end do + end do + + call xFFT3D(1, 1) + call xFFT3D(1, 2) + call xFFT3D(1, 3) + fields(:,:,:,1:3) = wrk(:,:,:,1:3) + + if (verbose) write(out,*) " --- initialized." + if (verbose) call flush(out) + + return +end subroutine init_velocity_taylor_green + + diff --git a/io_write_4.f90 b/io_write_4.f90 new file mode 100644 index 0000000..5cca4e2 --- /dev/null +++ b/io_write_4.f90 @@ -0,0 +1,92 @@ +subroutine io_write_4 + + ! Writing out the velocities and scalars in X-space + ! to the real*4 file + + use m_parameters + use m_fields + use m_work + use x_fftw + use m_les + + implicit none + + integer :: n_out, n, i, j, k + real*8 :: wmag2, rkmax2 + + ! every variable will undergo a mode truncation for all modes + ! that are higher than kmax. This will ensure that the written + ! variables are isotropic + + rkmax2 = real(kmax,8)**2 + + ! number of variables to write out + n_out = 3 + if (int_scalars) n_out = n_out + n_scalars + if (les .and. n_les>0) n_out = n_out + n_les + + ! putting all variables in wrk array + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + wmag2 = akx(i)**2 + aky(k)**2 + akz(j)**2 + + if (wmag2 .gt. rkmax2) then + wrk(i,j,k,1:n_out) = zip + else + wrk(i,j,k,1:n_out) = fields(i,j,k,1:n_out) + end if + + end do + end do + end do + + ! velocities + call xFFT3d(-1,1) + fname = 'u.'//file_ext + tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,1) + call write_tmp4 + + call xFFT3d(-1,2) + fname = 'v.'//file_ext + tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,2) + call write_tmp4 + + call xFFT3d(-1,3) + fname = 'w.'//file_ext + tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,3) + call write_tmp4 + + ! scalars + if (int_scalars) then + do n = 1,n_scalars + call xFFT3d(-1,3+n) + write(fname,"('sc',i2.2,'.',a6)") n,file_ext + tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,3+n) + call write_tmp4 + + end do + end if + + ! LES quantities + if (les) then + ! turbulent viscosity + if (allocated(turb_visc)) then + write(fname,"('nu_t.',a6)") file_ext + tmp4 = turb_visc + call write_tmp4 + end if + + if (n_les > 0) then + do n = 1, n_les + call xFFT3d(-1,3+n_scalars+n) + write(fname,"('les',i1,'.',a6)") n,file_ext + tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,3+n_scalars+n) + call write_tmp4 + end do + end if + + end if + + return +end subroutine io_write_4 diff --git a/m_fields.f90 b/m_fields.f90 new file mode 100644 index 0000000..1bb6da8 --- /dev/null +++ b/m_fields.f90 @@ -0,0 +1,414 @@ +module m_fields + + implicit none + + real*8, allocatable :: fields(:,:,:,:) + +!================================================================================ +contains +!================================================================================ + + subroutine m_fields_init + + use m_io + use m_parameters + implicit none + + integer :: n + + n = 3 + n_scalars + n_les + + allocate(fields(nx+2,ny,nz,n), stat=ierr) + if (ierr.ne.0) then + write(out,*) "Cannot allocate fields, stopping." + call my_exit(-1) + end if + fields = zip + + write(out,"('Allocated ',i3,' fields.')") n + call flush(out) + + + return + end subroutine m_fields_init + +!================================================================================ + + subroutine m_fields_exit + use m_io + implicit none + + if (allocated(fields)) deallocate(fields) + + write(out,*) 'fields deallocated.' + call flush(out) + + return + end subroutine m_fields_exit + +!================================================================================ + + +!-------------------------------------------------------------------------------- +! Subroutine that broadcasts the array "fields" from the hydro part to the +! "stats" part of the code +!-------------------------------------------------------------------------------- + subroutine fields_to_stats + + use m_openmpi + use m_parameters + use m_io + implicit none + + integer :: n_field, n_proc, k, ratio, n_scalars_bcast + + ! broadcasting time from the hydro root process to the whole world +!!$ write(out,*) "Broadcasting fields to stats part." +!!$ call flush(out) + + + ! first send it to the root process of the stats part + count = 1 + tag = 0 + if (iammaster) then + if (task.eq.'hydro') call MPI_SEND(TIME,count,MPI_REAL8,id_root_stats,tag,MPI_COMM_WORLD,mpi_err) + if (task.eq.'stats') call MPI_RECV(TIME,count,MPI_REAL8,id_root_hydro,tag,MPI_COMM_WORLD,mpi_status,mpi_err) +!!$ write(out,*) "Exchanged information between master processors." +!!$ call flush(out) + end if + ! then broadcast it over the "stats" communicator + if (task.eq.'stats') then + call MPI_BCAST(TIME,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + ! checking if we need to start advancing scalars + if (.not. int_scalars .and. TIME .gt. TSCALAR) then + int_scalars = .true. + write(out,*) "Starting to move the scalars." + call flush(out) + end if + end if +!!$ write(out,*) "Broadcasted to slave processors." +!!$ call flush(out) + + ! figuring out how many scalars to broadcast: + ! 0 if we do not move scalars + ! all if we move scalars + n_scalars_bcast = 0 + if (int_scalars) n_scalars_bcast = n_scalars +!!$ write(out,*) "Number of scalars to broadcast:", n_scalars_bcast +!!$ call flush(out) + + + if (numprocs_hydro .ge. numprocs_stats) then + + ! using the code structure: + ! since the size of the arrays is always 2^n, there is always 2^k slabs + ! of a "hydro" array that correspond to q slab of the "stats" array + + ratio = numprocs_hydro / numprocs_stats + + select case (task) + + case ('hydro') + + ! sending the fields array to the corresponding process in "stats" + do n_field = 1,3+n_scalars_bcast + count = (nx+2)*ny*nz + id_to = numprocs_hydro + floor(real(myid_world) / real(ratio)) + tag = myid_world*(3+n_scalars_bcast) + n_field-1 + +!!$ write(out,*) "Sending :", n_field, count, id_to, tag +!!$ call flush(out) + + call MPI_ISEND(fields(1,1,1,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + +!!$ write(out,*) "Sent." +!!$ call flush(out) + + end do + case ('stats') + + ! receiving fields from hydro processors + do n_proc = 0,ratio-1 + id_from = myid*ratio + n_proc + count = (nx+2)*ny*nz/ratio + k = (nz/ratio) * n_proc + 1 + do n_field = 1,3+n_scalars_bcast + tag = id_from*(3+n_scalars_bcast) + n_field-1 + +!!$ write(out,*) "Receiving :", n_field, count, id_from, tag +!!$ call flush(out) + + call MPI_IRECV(fields(1,1,k,n_field),count,MPI_REAL8,& + id_from,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + +!!$ write(out,*) "Received." +!!$ call flush(out) + + end do + end do + + end select + + else + + ! now doing the same for the case when more processors are involved in + ! the "stat" part than in "hydro" part + + ratio = numprocs_stats / numprocs_hydro + + select case (task) + + case ('hydro') + + do n_proc = 0,ratio-1 + count = (nx+2)*ny*nz/ratio + id_to = numprocs_hydro + myid_world*ratio + n_proc + k = (nz/ratio) * n_proc + 1 + do n_field = 1,3+n_scalars_bcast + tag = id_to*(3+n_scalars_bcast) + n_field-1 + call MPI_ISEND(fields(1,1,k,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + end do + end do + + case ('stats') + + do n_field = 1,3+n_scalars_bcast + count = (nx+2)*ny*nz + id_from = floor(real(myid) / real(ratio)) + tag = myid_world*(3+n_scalars_bcast) + n_field-1 + call MPI_RECV(fields(1,1,1,n_field),count,MPI_REAL8,& + id_from,tag,MPI_COMM_WORLD,mpi_status,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + end do + + end select + + end if + +!!$ write(out,*) "broadcasted fields to stats" +!!$ call flush(out) + + return + end subroutine fields_to_stats + + + +!================================================================================ +!================================================================================ +!-------------------------------------------------------------------------------- +! Subroutine that broadcasts the arrays that contain velocities in the x-space +! to the "parts" part of the code, for tracking particles +! The velocities are contained in the arrays wrk1...3 +! The whole ideology remains similar to the subroutine fields_to_stats, except +! for the fact that the parts part of the code receives the velocities into +! the "fields" array. +!-------------------------------------------------------------------------------- + subroutine fields_to_parts + + use m_openmpi + use m_parameters + use m_io + use m_work + implicit none + + integer :: n_field, n_proc, k, ratio, n_scalars_bcast + + ! if there are zero particles, return + if (nptot.eq.0) return + + + ! broadcasting time and timestep (dt) from the hydro root process + ! first send it to the root process of the "parts" part + count = 1 + if (iammaster) then + tag = 0 + if (task.eq.'hydro') call MPI_SEND(TIME,count,MPI_REAL8,id_root_parts,tag,MPI_COMM_WORLD,mpi_err) + if (task.eq.'parts') call MPI_RECV(TIME,count,MPI_REAL8,id_root_hydro,tag,MPI_COMM_WORLD,mpi_status,mpi_err) + tag = 1 + if (task.eq.'hydro') call MPI_SEND(dt,count,MPI_REAL8,id_root_parts,tag,MPI_COMM_WORLD,mpi_err) + if (task.eq.'parts') call MPI_RECV(dt,count,MPI_REAL8,id_root_hydro,tag,MPI_COMM_WORLD,mpi_status,mpi_err) + end if + ! then broadcast them over the "parts" communicator + if (task.eq.'parts') call MPI_BCAST(TIME,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + if (task.eq.'parts') call MPI_BCAST(dt ,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + ! if have not yet started moving particles, return + if (TIME.lt.starttime_particles) return + + ! if this is the first timestep when we need to start moving particles, + ! change the int_particle variable + if (TIME.ge.starttime_particles .and. .not. int_particles) then + write(out,*) 'Starting to move particles' + call flush(out) + int_particles = .true. + end if + + ! figure out if we broadcast scalars (currently not) + n_scalars_bcast = 0 + ! if (int_scalars) n_scalars_bcast = n_scalars + + + if (numprocs_hydro .ge. numprocs_parts) then + + ! using the code structure: + ! since the size of the arrays is always 2^n, there is always 2^k slabs + ! of a "hydro" array that correspond to q slab of the "parts" array + + ratio = numprocs_hydro / numprocs_parts + + select case (task) + + case ('hydro') + + ! sending the fields array to the corresponding process in "stats" + do n_field = 1,3+n_scalars_bcast + count = (nx+2)*ny*nz + id_to = id_root_parts + floor(real(myid_world) / real(ratio)) + tag = myid_world*(3+n_scalars_bcast) + n_field-1 + + ! if the paricles are advected by fully resolved velocity + ! ( that is, particles_filter_size=0) then send the fully resolved + ! velocity to the "parts" task +! Else, if the particles are advected by locally averaged velofity, send +! the velocities in the Fourier form. They will be locally averaged and +! processed by the "parts" part of the code + if (particles_filter_size .le. 0.d0) then + call MPI_ISEND(wrk(1,1,1,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + else + call MPI_ISEND(fields(1,1,1,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) +!!$ +!!$ write(out,*) id_to, n_field, fields(:,1,1,n_field) +!!$ call flush(out) +!!$ + end if + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + end do + case ('parts') + + ! receiving fields from hydro processors + do n_proc = 0,ratio-1 + id_from = myid*ratio + n_proc + count = (nx+2)*ny*nz/ratio + k = (nz/ratio) * n_proc + 1 + do n_field = 1,3+n_scalars_bcast + tag = id_from*(3+n_scalars_bcast) + n_field-1 + + call MPI_IRECV(fields(1,1,k,n_field),count,MPI_REAL8,& + id_from,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) +!!$ +!!$ write(out,*) 'rec',id_from, n_field, fields(:,1,k,n_field) +!!$ call flush(out) +!!$ + end do + end do + + end select + + else + + ! now doing the same for the case when more processors are involved in + ! the "parts" part than in "hydro" part + + ratio = numprocs_parts / numprocs_hydro + + select case (task) + + case ('hydro') + + do n_proc = 0,ratio-1 + count = (nx+2)*ny*nz/ratio + id_to = id_root_parts + myid_world*ratio + n_proc + k = (nz/ratio) * n_proc + 1 + do n_field = 1,3+n_scalars_bcast + tag = id_to*(3+n_scalars_bcast) + n_field-1 + if (particles_filter_size .le. 0.d0) then + call MPI_ISEND(wrk(1,1,k,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + else + call MPI_ISEND(fields(1,1,k,n_field),count,MPI_REAL8,id_to,tag,MPI_COMM_WORLD,mpi_request,mpi_err) + end if + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + end do + end do + + case ('parts') + + do n_field = 1,3+n_scalars_bcast + count = (nx+2)*ny*nz + id_from = floor(real(myid) / real(ratio)) + tag = myid_world*(3+n_scalars_bcast) + n_field-1 + call MPI_RECV(fields(1,1,1,n_field),count,MPI_REAL8,& + id_from,tag,MPI_COMM_WORLD,mpi_status,mpi_err) + call MPI_WAIT(mpi_request,mpi_status,mpi_err) + end do + + end select + + end if + + return + end subroutine fields_to_parts + + + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ + +!!$ +!!$ subroutine check_bcast +!!$ +!!$ use m_parameters +!!$ use m_io +!!$ use m_work +!!$ implicit none +!!$ +!!$ integer :: i,j,k,n +!!$ real*8 :: zyu +!!$ +!!$ ! defining the fields to be cosines (testing) +!!$ zyu = 1.0 +!!$ if (task.eq.'hydro') then +!!$ do n = 1,3 +!!$ do k = 1,nz +!!$ do j = 1,ny +!!$ do i = 1,nx +!!$ +!!$ +!!$ fields(i,j,k,n) = sin(dble(n*i)*dx) +!!$ +!!$ end do +!!$ end do +!!$ end do +!!$ end do +!!$ end if +!!$ +!!$ +!!$ call m_fields_bcast +!!$ +!!$ +!!$ do n = 1,3 +!!$ +!!$ if (task.eq.'hydro') write(fname,"('hydro',i1,'.arr')") n +!!$ if (task.eq.'stats') write(fname,"('stats',i1,'.arr')") n +!!$ +!!$ tmp4(:,:,:) = fields(1:nx,:,:,n) +!!$ call write_tmp4 +!!$ end do +!!$ +!!$ return +!!$ end subroutine check_bcast +!!$ + + + +end module m_fields + + diff --git a/m_filter_xfftw.f90 b/m_filter_xfftw.f90 new file mode 100644 index 0000000..0df033f --- /dev/null +++ b/m_filter_xfftw.f90 @@ -0,0 +1,289 @@ +!====================================================================== +! Module that contains filtering rocedure for the part of the code that +! addvects lagrangian particles +! +! Time-stamp: <2009-05-20 11:50:52 (chumakov)> +!====================================================================== +module m_filter_xfftw + + use m_parameters + use x_fftw + use m_work + implicit none + + ! filter type (Gaussian by default) + integer :: filter_type = 2 + + ! filter size + real*8 :: filter_size + + ! filter function in Fourier space + real*8, allocatable :: filter_g(:,:,:) + +!====================================================================== +contains +!====================================================================== + +!====================================================================== +! filering subroutine for 2*pi^3-periodic domain +! IN: ss(n,:,:,:) +! OUT: ss(n:,;,:) +!====================================================================== + subroutine filter_xfftw(n) + + use m_io + implicit none + + integer n + + integer :: ix, iy, iz + + real*8 :: a,b,c,d + +!---------------------------------------------------------------------- + +!!$ call xFFT3d(1,n) + + ! multiplying wrk(:,:,:,n) by filter_g + ! remember both are in the complex form + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx + 1, 2 + a = wrk(ix,iz,iy,n) + b = wrk(ix+1,iz,iy,n) + c = filter_g(ix,iz,iy) + d = filter_g(ix+1,iz,iy) + + wrk(ix , iz, iy, n) = a*c - b*d + wrk(ix + 1, iz, iy, n) = b*c + a*d + end do + end do + end do + +!!$ ! perform inverse FFT +!!$ call xFFT3d(-1,n) + + return + end subroutine filter_xfftw + +!====================================================================== +! filering subroutine for 2*pi^3-periodic domain +! IN: ss(n,:,:,:) +! OUT: ss(n:,;,:) +!====================================================================== + subroutine filter_xfftw_fields(n) + + use m_io + use m_fields + implicit none + + integer n + + integer :: ix, iy, iz + + real*8 :: a,b,c,d + +!---------------------------------------------------------------------- + +!!$ call xFFT3d(1,n) + + ! multiplying wrk(:,:,:,n) by filter_g + ! remember both are in the complex form + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx + 1, 2 + a = fields(ix,iz,iy,n) + b = fields(ix+1,iz,iy,n) + c = filter_g(ix,iz,iy) + d = filter_g(ix+1,iz,iy) + + fields(ix , iz, iy, n) = a*c - b*d + fields(ix + 1, iz, iy, n) = b*c + a*d + end do + end do + end do + +!!$ ! perform inverse FFT +!!$ call xFFT3d(-1,n) + + return + end subroutine filter_xfftw_fields + +!====================================================================== +!====================================================================== +!====================================================================== +! subroutine that initializes the filter function filter_g +! IN: filter_type - type of the filter +! delta - filter's characteristic width +! +! OUT: filter_g - normalized FFT of the filter function +!====================================================================== + subroutine filter_xfftw_init + + use m_parameters + use m_io + use m_work + implicit none + + real*8 delta + + integer :: di,dj,dk,i,j,k, m + integer :: idelta,sum1 + integer :: ii(8) + real*8 :: rx,ry,rz + real*8 :: const1,const2 + + filter_size = particles_filter_size + delta = filter_size + + if (task.eq.'hydro') delta = dx*four + + if (delta .lt. dx*three) then + write(out,*) "filter_xfftw_init: delta is too small:",delta,dx + write(out,*) "Must be at least 3*dx = ",three*dx + call flush(out) + call my_exit(-1) + end if + + write(out,"('initializing the filter, filter_size = ',2e15.6)") delta, dx + call flush(out) + + ! the main idea is as follows: + ! 1) create the filter kernel in one of the fields array + ! 2) transform it into the Fourier space + ! 3) put it into the array filter_g + + ! number of the slice in the fields array that will be used + m = LBOUND(fields,4) + + +!--------------------------------------------------------------- +! define the filtering function +!--------------------------------------------------------------- + case_filter_type: select case (filter_type) + +!------------------------------------------------------------------- +! tophat filter +!------------------------------------------------------------------- + case (1) + write(out,*) '-- tophat filter, delta =',delta + + write(out,*) "Tophat filter is not working at the moment." + write(out,*) "We're sorry for the inconvenience, stopping." + call my_exit(-1) + + fields(:,:,:,m) = zip + + idelta = delta / dx / 2 + ! normalization constant + const1 = real((2*idelta+1)**3,8) + const2 = 1.0d0 / const1 + do k = 1,nz + dk = min(myid*nz+k-1,nz*numprocs-(myid*nz+k)+1) + do j = 1,ny + dj = min(j-1,ny-j+1) + do i = 1,nx + di = min(i-1,nx-i+1) + fields(i,j,k,m) = zip + if (di.le.idelta .and. dj.le.idelta .and. dk.le.idelta) then + fields(i,j,k,m) = const2 + end if + end do + end do + end do +!------------------------------------------------------------------- +! Gaussian filter +!------------------------------------------------------------------- + case (2) + write(out,*) '-- Gaussian filter, delta =',delta + call flush(out) + + fields(:,:,:,m) = zip + + const1 = 6.0d0 / delta**2 + const2 = sqrt(const1/PI)**3 *dx**3 + + do k = 1,nz + dk = min(myid*nz+k-1,nz*numprocs-(myid*nz+k)+1) + rz = dx * real(dk,8) + do j = 1,ny + dj = min(j-1,ny-j+1) + ry = dx * real(dj,8) + do i = 1,nx + di = min(i-1,nx-i+1) + rx = dx * real(di,8) + rx = rx*rx+ry*ry+rz*rz + fields(i,j,k,m) = const2*exp(-const1*rx) + if (fields(i,j,k,m) < 1.e-20) fields(i,j,k,m) = zip + end do + end do + end do + +!------------------------------------------------------------------- +! linear filter +!------------------------------------------------------------------- + case(3) + write(out,*) '-- linear filter, delta =',delta +! if(myid.eq.0) print*,'-- linear filter, delta =',delta + const1 = 24.0d0 / (PI*delta**3) *dx**3 + const2 = delta**2 / 4.0d0 + do k = 1,nz + dk = min(myid*nz+k-1,nz*numprocs-(myid*nz+k)+1) + rz = dx * real(dk,8) + do j = 1,ny + dj = min(j-1,ny-j+1) + ry = dx * real(dj,8) + do i = 1,nx + di = min(i-1,nx-i+1) + rx = dx * real(di,8) + + rx = rx*rx+ry*ry+rz*rz + fields(i,j,k,m) = zip + if (rx.le.const2) fields(i,j,k,m) = & + const1*(1.0d0-2.0d0*sqrt(rx)/delta) + end do + end do + end do + + case default + print *,'FILTER_FFT_INIT: wrong filter_type:',filter_type + stop + end select case_filter_type + + ! outputting the sum of all elements of G. + ! It should equal 1.0. + const1 = sum(fields(1:nx,1:ny,1:nz,m)) + call MPI_REDUCE(const1,const2,1,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + if(myid.eq.0) write(out,*) '-- NORM OF G: ',const2 + + ! compute FFT of g + call xFFT3d_fields(1,m) + + ! putting the FFT of the filter into filter_g. + ! allocating the filter array + if (.not.allocated(filter_g)) then + allocate(filter_g(nx+2,ny,nz), stat=ierr) + if (ierr /= 0) stop 'cannot allocate filter_g' + filter_g = zip + write(out,*) 'allocated filter_g' + call flush(out) + end if + filter_g(:,:,:) = fields(:,:,:,m) + +!!$! no need to normalize filter_g because our implementation of FFT +!!$! normalizes the result anyways +!!$ const1 = one/real(nx**3,8) +!!$ do k=1,nz +!!$ do j=1,ny +!!$ do i=1,nx+2 +!!$ filter_g(i,j,k) = wrk(i,j,k,m)*const1 +!!$ end do +!!$ end do +!!$ end do + + + return + end subroutine filter_xfftw_init + + +end module m_filter_xfftw diff --git a/m_force.f90 b/m_force.f90 new file mode 100644 index 0000000..da0f8bf --- /dev/null +++ b/m_force.f90 @@ -0,0 +1,185 @@ +module m_force + + use m_parameters, only : kfmax, famp, force_type + + + integer*4 :: n_forced_nodes, n_forced_nodes_total + + ! coordinated of the forced nodes + integer, allocatable :: ifn(:), jfn(:), kfn(:), k_shell(:) + +contains + + subroutine m_force_init + + use m_parameters + use x_fftw + + implicit none + + integer :: i, j, k, n, n_shell + + ! if flow is not forced, return + if (flow_type .ne. 1) return + + if (task.ne.'hydro') return + + select case (force_type) + + case (1) + ! Machiels forcing (see article in PRL #79(18) p.3411) + write(out,*) "Forcing #1: Machiels forcing - setting up" + call flush(out) + + ! find out how many nodes are we forcing and book them + n_forced_nodes = 0 + n_forced_nodes_total = 0 + do k = 1,nz + do j = 1,ny + do i = 1,nx + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kfmax) then + n_forced_nodes = n_forced_nodes + 1 + end if + end do + end do + end do + + ! reducing to the master process to find out the total number of forced nodes +!!$ write(out,*) 'before reducing'; call flush(out) + count = 1 + call MPI_REDUCE(n_forced_nodes, n_forced_nodes_total, count, & + MPI_INTEGER4,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + + ! writing out the # of forced nodes + write(out,*) 'Number of forced nodes for this process:',n_forced_nodes + if (myid.eq.0) write(out,*) ' total number:',n_forced_nodes_total + call flush(out) + + ! allocating arrays for the coordinates of the forced nodes + allocate(ifn(n_forced_nodes), jfn(n_forced_nodes), kfn(n_forced_nodes), & + k_shell(n_forced_nodes)) + + ! filling up the arrays + n = 0 + do k = 1,nz + do j = 1,ny + do i = 1,nx + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kfmax) then + n = n + 1 + ifn(n) = i + jfn(n) = j + kfn(n) = k + k_shell(n) = n_shell + end if + end do + end do + end do + +!!$ ! writing out the nodes +!!$ do n = 1,n_forced_nodes +!!$ write(out,"(3i4)") ifn(n),jfn(n),kfn(n) +!!$ end do +!!$ call flush(out) + + case default + + write(out,*) 'WRONG FORCE TYPE:',force_type + write(out,*) 'STOPPING' + call flush(out) + stop + + end select + + + return + end subroutine m_force_init + +!================================================================================ + + subroutine force_velocity + + ! adding forcing to the arrays wrk(:,:,:,1:3) that already contain the RHS for velocities + + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + use m_stats + + implicit none + + integer :: i, j, k, n_shell, n + + real*8 :: fac, fac2 + + select case (force_type) + + + case (1) + ! Machiels forcing (see article in PRL #79(18) p.3411) + ! write(out,*) "Machiels forcing"; call flush(out) + + e_spec = zip + e_spec1 = zip + hits = 0 + hits1 = 0 + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + ! assembling the total energy in each shell + do k = 1,nz + do j = 1,ny + do i = 1,nx + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kfmax) then + fac2 = fac * (fields(i,j,k,1)**2 + fields(i,j,k,2)**2 + fields(i,j,k,3)**2) + if (akx(i).eq.0.d0) fac2 = fac2 * 0.5d0 + e_spec1(n_shell) = e_spec1(n_shell) + fac2 + end if + end do + end do + end do + ! reducing the number of hits and energy to two arrays on master node + count = kfmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + + ! getting the total energy in the region [0:kfmax] by integrating the spectrum + if (myid.eq.0) energy = sum(e_spec(1:kfmax)) + + ! broadcasting the current energy in the forcing range of wavenumbers + count = 1 + call MPI_BCAST(energy,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + ! now applying the forcing to the RHS for velocities (wrk(:,:,:,1:3)) + + fac = FAMP / energy + + do n = 1,n_forced_nodes + n_shell = k_shell(n) + i = ifn(n) + j = jfn(n) + k = kfn(n) + + wrk(i,j,k,1) = wrk(i,j,k,1) + fac * fields(i,j,k,1) + wrk(i,j,k,2) = wrk(i,j,k,2) + fac * fields(i,j,k,2) + wrk(i,j,k,3) = wrk(i,j,k,3) + fac * fields(i,j,k,3) + + end do + + + case default + write(out,*) "WRONG FORCE_TYPE:",force_type + stop + end select + + return + end subroutine force_velocity + + +end module m_force diff --git a/m_io.f90 b/m_io.f90 new file mode 100644 index 0000000..c0c41c4 --- /dev/null +++ b/m_io.f90 @@ -0,0 +1,53 @@ +!================================================================================ +! M_IO - module that contains the I/O related subroutines. +! +! Time-stamp: <2008-11-04 15:31:31 (chumakov)> +!================================================================================ + +module m_io + + use m_openmpi + implicit none + + character*6 :: file_ext + character*80 :: fname + ! output file handle + integer :: in=10, out=11 + + + +!================================================================================ +contains +!================================================================================ +!================================================================================ + subroutine m_io_init + + implicit none + + write(fname,"('d',i4.4,'.txt')") myid_world + open(out,file=fname,position="append") + write(out,"('-------------------------------------')") + write(out,"('Process ',i4,' of ',i4,'(',i4.4,') is alive.')") & + myid_world, numprocs_world, numprocs_world-1 + write(out,"('My task is ""',a5,'"", my id is',i4)") task, myid + call flush(out) + + return + end subroutine m_io_init + +!================================================================================ +!================================================================================ + subroutine m_io_exit + implicit none + write(out,"('Done.')") + close(out) + return + end subroutine m_io_exit + +!================================================================================ +!================================================================================ + + +!================================================================================ +!================================================================================ +end module m_io diff --git a/m_les.f90 b/m_les.f90 new file mode 100644 index 0000000..fa4113f --- /dev/null +++ b/m_les.f90 @@ -0,0 +1,2396 @@ +!================================================================================ +! m_les - the module that contains all subroutines and variables that are +! needed to introduce Large Eddy Simulation (LES) into the code. +! +! The behaviour of the module is governed by the variable "les_mode" from the +! module m_parameters.f90 +! +! Time-stamp: <2010-03-18 13:52:33 (chumakov)> +!================================================================================ +module m_les + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + implicit none + + +!================================================================================ +! Arrays and constants +!================================================================================ + + ! indicator, whether we use LES at all + logical :: les = .false. + + ! model switch "les_mode" is contained by m_parameters + ! integer(kind=4) :: les_model + + ! array for turbulent viscosity + real(kind=8), allocatable :: turb_visc(:,:,:) + + ! LES sources for velocities + real(kind=8), allocatable :: vel_source_les(:,:,:,:) + + ! separate array for the subgrid stress + real(kind=8), allocatable :: tauij(:,:,:,:) + + ! Smagorinsky constant + real(kind=8) :: c_smag = 0.18 + + ! Scaling constant for the lag-model + real(kind=8) :: C_T = 1.d0 + + ! Scaling constant for the mixed model + real(kind=8) :: C_mixed + + ! test filter width + real(kind=8) :: les_delta + + ! array with the test filter in it + real(kind=8), allocatable :: filter_g(:,:,:) + + ! model indicator for the output + character*3 :: les_model_name = ' ' + + ! TEMP variables: + ! - production + real(kind=8) :: energy, production, B, dissipation + +!================================================================================ +! SUBROUTINES +!================================================================================ +contains +!================================================================================ +! Allocation of LES arrays +!================================================================================ + subroutine m_les_init + + implicit none + + integer :: n + real*8, allocatable :: sctmp(:) + + + ! if les_model=0, do not initialize anything and return + if (les_model==0) return + + write(out,*) 'Initializing LES...' + call flush(out) + + ! depending on the value of les_model, initialize different things + les = .true. + ! initialize the filter width to be equal to the grid spaxing + les_delta = dx + write(out,*) 'LES_DELTA = ',les_delta + ! initializeing stuff based on the model switch "les_model" + select case (les_model) + +!-------------------------------------------------------------------------------- +! Smagorinsky model +!-------------------------------------------------------------------------------- + case(1) + write(out,*) ' - Smagorinsky model: initializing the eddy viscosity' + call flush(out) + allocate(turb_visc(nx,ny,nz),stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 0 + les_model_name = " SM" + +!-------------------------------------------------------------------------------- +! Dynamic localization model +!-------------------------------------------------------------------------------- + case(2) + write(out,*) ' - DL model: initializing the eddy viscosity and adding extra transport equation' + call flush(out) + allocate(turb_visc(nx,ny,nz),stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 1 + les_model_name = "DLM" + +!-------------------------------------------------------------------------------- +! Dynamic localization model + lag model for the subgrid energy dissipation +!-------------------------------------------------------------------------------- + case(3) + ! Dynamic Localization model + lag model for the dissipation + write(out,*) ' - DL model + lag-model for dissipation' + call flush(out) + allocate(turb_visc(nx,ny,nz),stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 3 + les_model_name = "DLL" + +!-------------------------------------------------------------------------------- +! Dynamic Structure model + algebraic model for dissipation +!-------------------------------------------------------------------------------- + + case(4) + + write(out,*) ' - DSt model + algebraic model for dissipation' + call flush(out) + allocate(turb_visc(nx,ny,nz), vel_source_les(nx+2,ny,nz,3), stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 1 + les_model_name = "DST" + + ! Fot this model we need a filter. The filter cannot be initialized + ! without previous initialization of fields array. So initialization of + ! the filter is done in m_les_begin + + ! Note that for this model we need a bigger wrk array + ! this is taken care of in m_work.f90 + +!-------------------------------------------------------------------------------- +! Dynamic Structure model + lag model for dissipation +!-------------------------------------------------------------------------------- + case(5) + + write(out,*) ' - DSt model + lag model for dissipation' + call flush(out) + allocate(turb_visc(nx,ny,nz), vel_source_les(nx+2,ny,nz,3), stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 3 + les_model_name = "STL" + + ! Fot this model we need a filter. The filter cannot be initialized + ! without previous initialization of fields array. So initialization of + ! the filter is done in m_les_begin + + ! Note that for this model we need a bigger wrk array + ! this is taken care of in m_work.f90 + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + inquire(file = 'c_t.in', exist = there) + if (.not.there) then + write(out,*) "Cannot find the file 'c_t.in', exiting" + call my_exit(-1) + end if + if (iammaster) then + open(900,file='c_t.in') + read(900,*) C_T + close(900) + end if + count = 1 + call MPI_BCAST(C_T,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + write(out,*) "DSTM + lag model WITH C_T = ",C_T + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + +!-------------------------------------------------------------------------------- +! Mixed model: Dynamic Structure + C-mixed * Dynamic Localization model +! Dissipation model is algebraic +!-------------------------------------------------------------------------------- + case(6) + + write(out,*) ' - MIXED MODEL: DSTM + DLM' + write(out,*) ' - Dissipation is algebraic' + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + inquire(file = 'c_mixed.in', exist = there) + if (.not.there) then + write(out,*) "Cannot find the file 'c_mixed.in', exiting" + call my_exit(-1) + end if + if (iammaster) then + open(900,file='c_mixed.in') + read(900,*) C_mixed + close(900) + end if + count = 1 + call MPI_BCAST(C_mixed,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + write(out,*) "MIXED MODEL WITH C_MIXED = ",C_mixed + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + + allocate(turb_visc(nx,ny,nz), vel_source_les(nx+2,ny,nz,3), stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 1 + les_model_name = "MMA" + + ! Fot this model we need a filter. The filter cannot be initialized + ! without previous initialization of fields array. So initialization of + ! the filter is done in m_les_begin + + ! Note that for this model we need a bigger wrk array + ! this is taken care of in m_work.f90 + + +!-------------------------------------------------------------------------------- +! Mixed model: Dynamic Structure + some viscosity (about 15% of the usual) +! Dissipation model is lag-model +!-------------------------------------------------------------------------------- + case(7) + + write(out,*) ' - MIXED MODEL: DSTM + eddy viscosity' + write(out,*) ' - Lag-model for Dissipation' + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + inquire(file = 'c_mixed.in', exist = there) + if (.not.there) then + write(out,*) "Cannot find the file 'c_mixed.in', exiting" + call my_exit(-1) + end if + if (iammaster) then + open(900,file='c_mixed.in') + read(900,*) C_mixed + close(900) + end if + count = 1 + call MPI_BCAST(C_mixed,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + write(out,*) "MIXED MODEL WITH C_MIXED = ",C_mixed + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + + allocate(turb_visc(nx,ny,nz), vel_source_les(nx+2,ny,nz,3), stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the turbulent viscosity array' + call flush(out) + call my_exit(-1) + end if + turb_visc = 0.0d0 + + n_les = 3 + les_model_name = "MML" + + ! Fot this model we need a filter. The filter cannot be initialized + ! without previous initialization of fields array. So initialization of + ! the filter is done in m_les_begin + + ! Note that for this model we need a bigger wrk array + ! this is taken care of in m_work.f90 + +!-------------------------------------------------------------------------------- +! LES MODEL # 10 +! +! One-equation mixed model for the momentum closure (DSTM + C_mixed * SM) +! Lag model for the closure of the k-equation +! Harlow model for closure of the scalar tranport equation +!-------------------------------------------------------------------------------- + case(10) + write(out,*) ' LES MODEL # 10' + write(out,*) ' - MIXED MODEL: DSTM + eddy viscosity' + write(out,*) ' Lag-model for Dissipation' + write(out,*) ' - SCALARS: Harlow model' + write(out,*) ' ============> file c_mixed.in is still required' + call flush(out) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + inquire(file = 'c_mixed.in', exist = there) + if (.not.there) then + write(out,*) "Cannot find the file 'c_mixed.in', making default 0.5" + c_mixed = 0.5d0 + else + if (iammaster) then + open(900,file='c_mixed.in') + read(900,*) C_mixed + close(900) + end if + count = 1 + call MPI_BCAST(C_mixed,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + end if + write(out,*) "MIXED MODEL WITH C_MIXED = ",C_mixed + call flush(out) +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + + allocate(turb_visc(nx,ny,nz), tauij(nx+2,ny,nz,6), stat=ierr) + if (ierr/=0) then + write(out,*) 'Cannot allocate the auxiliary arrays' + call flush(out) + call my_exit(-1) + end if + turb_visc = zip + tauij = zip + + ! number of extra LES quantities is 2: (BT), (eps * T) + n_les = 2 + les_model_name = "#10" + + ! For this model we need a filter. The filter cannot be initialized + ! without previous initialization of fields array. So initialization of + ! the filter is done in m_les_begin + + ! Note that for this model we need a bigger wrk array + ! this is taken care of in m_work.f90 + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + + + case default + write(out,*) 'M_LES_INIT: invalid value of les_model:',les_model + call flush(out) + call my_exit(-1) + end select + +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- + + write(out,*) "n_les = ", n_les + + ! If the number of LES quantities is non-zero, then for the sake of modularity + ! we need to have SC and PE numbers defined for those quantities. For this we + ! need to re-allocate the arrays SC and PE + additional_scalars: if (n_les .gt. 0) then + write(out,*) "Adding elements to arrays PE and SC for the LES-related scalars..." + call flush(out) + allocate(sctmp(1:n_scalars+n_les), stat=ierr) + sctmp(1:n_scalars) = sc(1:n_scalars) + sctmp(n_scalars+1:n_scalars+n_les) = one + if (allocated(sc)) deallocate(sc) + allocate(sc(1:n_scalars+n_les)) + sc = sctmp + if (allocated(pe)) deallocate(pe) + allocate(pe(1:n_scalars+n_les)) + pe = nu / sc + deallocate(sctmp) + write(out,*) " ...done." + call flush(out) + end if additional_scalars + + write(out,*) 'initialized LES.' + call flush(out) + + return + end subroutine m_les_init + +!================================================================================ +!================================================================================ +! initialization of the LES arrays - part 2 +! definition of the arrays +! +! called after the restart +!================================================================================ + subroutine m_les_begin + + use m_filter_xfftw + implicit none + + write(out,*) "M_LES_BEGIN..." + call flush(out) + + select case(les_model) + +!-------------------------------------------------------------------------------- +! if les_model=0, do not initialize anything and return +! also don't do anything if the model is Smagorinsky model - it does not +! need any additional initialization beside the array allocation which has +! been already done. +!-------------------------------------------------------------------------------- + case(0) + return + case(1) + return + +!-------------------------------------------------------------------------------- +! Dynamic localization model +!-------------------------------------------------------------------------------- + case(2) + write(out,*) "-- DLM model" + call flush(out) + + if (itime.eq.0) then + write(out,*) "-- Initializing k_sgs" + call flush(out) + call m_les_dlm_k_init + end if + +!-------------------------------------------------------------------------------- + case(3) + write(out,*) "-- DLM model with lag model for dissipation" + call flush(out) + + if (itime.gt.0) return + + ! call m_les_dlm_k_init + + ! COMMENT OUT THE FOLLOWING IN ORDER TO INITIALIZE B AND EPSILON AS ZERO + + ! making initial epsilon = k^(3/2)/Delta everywhere + ! since k=const=0.5, just change one entry in epsilon array + ! Note that the array itself contains not epsilon but (epsilon * T_epsilon) + ! so the contents of the array is not presicely k^(3/2)/Delta. Some math is involved. + ! (comment out to start from zero dissipation) + ! if (iammaster) fields(1,1,1,3+n_scalars+3) = C_T * 0.5 * real(nxyz_all) + + ! Now initial conditions for B. We want B to be same as epsilon + ! (kind of "starting from steady state"), but again the array contains B*T_B, not just B. + ! Current implementation is T_B = 1/|S|. To get |S|, we call m_les_src_k_dlm, which + ! gives us |S|^2 in wrk0. + ! call m_les_k_src_dlm + ! now wrk0 contains |S|^2 in x-space, and we can use it to get B + ! fields(:,:,:,3+n_scalars+2) = 0.5**1.5d0 / les_delta / sqrt(wrk(:,:,:,0)) + ! call xFFT3d_fields(1,3+n_scalars+2) + + ! INITIALIZING K_SGS, B*T_B and eps*T_eps + ! Initializing them so that k_sgs = B*T_b + eps*T_eps + ! in fact this makes the equation for k_sgs unnecessary but we're keeping it for + ! debug purposes and such + + write(out,*) " Initializing k_sgs = 0.1, B*T_B = eps*T_eps = 0.05" + call flush(out) + ! definition of k_sgs = 0.1 everywhere + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.1d0 * real(nxyz_all) + ! definition of eps*T_eps = B*T_B = 0.5 k_sgs + if (iammaster) fields(1,1,1,3+n_scalars+2) = 0.5d0 * fields(1,1,1,3+n_scalars+1) + if (iammaster) fields(1,1,1,3+n_scalars+3) = 0.5d0 * fields(1,1,1,3+n_scalars+1) + +!-------------------------------------------------------------------------------- + + case(4) + + write(out,*) "-- Dynamic Structure model with algebraic model for dissipation" + call flush(out) + + ! initializing filtering arrays + ! because filter_xfftw_init uses fields(1) as a temporary array, we need + ! to store it before we initialize the filter, and the restore it to + ! what it was. + wrk(:,:,:,LBOUND(wrk,4)) = fields(:,:,:,LBOUND(fields,4)) + call filter_xfftw_init + fields(:,:,:,LBOUND(fields,4)) = wrk(:,:,:,LBOUND(wrk,4)) + + if (itime.eq.0) then + write(out,*) "-- Initializing k_sgs = 0.2" + call flush(out) + + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.2d0 * real(nxyz_all) + end if + +!-------------------------------------------------------------------------------- + + case(5) + + write(out,*) "-- Dynamic Structure model with lag-model for dissipation" + call flush(out) + + ! initializing filtering arrays + ! because filter_xfftw_init uses fields(1) as a temporary array, we need + ! to store it before we initialize the filter, and the restore it to + ! what it was. + wrk(:,:,:,LBOUND(wrk,4)) = fields(:,:,:,LBOUND(fields,4)) + call filter_xfftw_init + fields(:,:,:,LBOUND(fields,4)) = wrk(:,:,:,LBOUND(wrk,4)) + + + if (itime.eq.0) then + write(out,*) "-- Initializing k_sgs = 0.5" + call flush(out) + + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.5d0 * real(nxyz_all) + ! definition of eps*T_eps = 0, B*T_B = k_sgs + if (iammaster) fields(1,1,1,3+n_scalars+2) = fields(1,1,1,3+n_scalars+1) + if (iammaster) fields(1,1,1,3+n_scalars+3) = 0.d0*fields(1,1,1,3+n_scalars+1) + end if + +!-------------------------------------------------------------------------------- + + case(6) + + write(out,*) "-- MIXED MODEL (Dynamic Structure model + Smagorinsky)" + write(out,*) " Algebraic model for dissipation" + call flush(out) + + ! initializing filtering arrays + ! because filter_xfftw_init uses fields(1) as a temporary array, we need + ! to store it before we initialize the filter, and the restore it to + ! what it was. + write(out,*) "Initializing filter" + call flush(out) + wrk(:,:,:,LBOUND(wrk,4)) = fields(:,:,:,LBOUND(fields,4)) + call filter_xfftw_init + fields(:,:,:,LBOUND(fields,4)) = wrk(:,:,:,LBOUND(wrk,4)) + + if (itime.eq.0) then + + write(out,*) "-- Initializing k_sgs = 0.5" + call flush(out) + + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.5d0 * real(nxyz_all) + + end if + +!-------------------------------------------------------------------------------- + + case(7) + + write(out,*) "-- MIXED MODEL (Dynamic Structure model + Smagorinsky)" + write(out,*) " Lag-model for dissipation" + call flush(out) + + ! initializing filtering arrays + ! because filter_xfftw_init uses fields(1) as a temporary array, we need + ! to store it before we initialize the filter, and the restore it to + ! what it was. + write(out,*) " Initializing filter" + call flush(out) + wrk(:,:,:,LBOUND(wrk,4)) = fields(:,:,:,LBOUND(fields,4)) + call filter_xfftw_init + fields(:,:,:,LBOUND(fields,4)) = wrk(:,:,:,LBOUND(wrk,4)) + + + if (itime.eq.0) then + + write(out,*) "-- Initializing k_sgs = 0.5, (BT)=k_s, (Eps T) = 0" + call flush(out) + + ! Initializing k + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.5d0 * real(nxyz_all) + ! initializing (BT) + if (iammaster) fields(1,1,1,3+n_scalars+2) = fields(1,1,1,3+n_scalars+1) + ! initializing (eps T) + if (iammaster) fields(1,1,1,3+n_scalars+3) = 0.d0*fields(1,1,1,3+n_scalars+1) + + end if + +!-------------------------------------------------------------------------------- + + case(10) + + write(out,*) "-- MIXED MODEL (Dynamic Structure model + Smagorinsky)" + write(out,*) " Lag-model for dissipation" + call flush(out) + + ! initializing filtering arrays + ! because filter_xfftw_init uses fields(1) as a temporary array, we need + ! to store it before we initialize the filter, and the restore it to + ! what it was. + write(out,*) " Initializing filter" + call flush(out) + wrk(:,:,:,LBOUND(wrk,4)) = fields(:,:,:,LBOUND(fields,4)) + call filter_xfftw_init + fields(:,:,:,LBOUND(fields,4)) = wrk(:,:,:,LBOUND(wrk,4)) + + if (itime.eq.0) then + write(out,*) "-- (BT) = 0.1, (Eps T) = 0.1" + call flush(out) + ! No need to initialize k_s, since k_s = (BT)+(eps T) + ! if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.5d0 * real(nxyz_all) + ! initializing (BT) + if (iammaster) fields(1,1,1,3+n_scalars+1) = 0.1d0 * real(nxyz_all) + ! initializing (eps T) + if (iammaster) fields(1,1,1,3+n_scalars+2) = 0.1d0 * real(nxyz_all) + end if + +!-------------------------------------------------------------------------------- + + case default + write(out,*) "M_LES_BEGIN: invalid value of les_model: ",les_model + call flush(out) + call my_exit(-1) + end select + + + return + end subroutine m_les_begin + +!================================================================================ +!================================================================================ +! Adding LES sources to the RHS of velocities +!================================================================================ + subroutine les_rhs_velocity + + use x_fftw + implicit none + + integer :: i, j, k + + select case (les_model) + case(1:3) + call les_rhsv_turb_visc + case(4:5) + ! Dynamic Structure model + ! add the velocity sources to RHS for velocitieis + wrk(:,:,:,1:3) = wrk(:,:,:,1:3) + vel_source_les(:,:,:,1:3) + + case(6) + ! Mixed model (DSTM + DLM) + ! add the velocity sources to RHS for velocitieis + wrk(:,:,:,1:3) = wrk(:,:,:,1:3) + vel_source_les(:,:,:,1:3) + ! also apply turbulent viscosity + call les_rhsv_turb_visc + + case(7) + ! Mixed model (DSTM + DLM) + lag-model for dissipation of k_sgs + ! add the velocity sources to RHS for velocitieis + wrk(:,:,:,1:3) = wrk(:,:,:,1:3) + vel_source_les(:,:,:,1:3) + ! also apply turbulent viscosity to velocities + call les_rhsv_turb_visc + + case(10) + ! Mixed model (DSTM + DLM) + lag-model for dissipation of k_sgs + ! add the velocity sources to RHS for velocitieis + ! The sources are directly computed from the array tauij + ! so we do not need a separate array for them + call les_add_vel_source_from_tauij + + case default + write(out,*) 'LES_RHS_VELOCITY: invalid value of les_model:',les_model + call flush(out) + call my_exit(-1) + end select + +!-------------------------------------------------------------------------------- +! Making sure that we are not getting any aliasing errors. That is done by +! making RHS zero for wavenumbers that are aliased. +!-------------------------------------------------------------------------------- + do k = 1, nz + do j = 1, ny + do i = 1, nx + 2 + if (ialias(i,j,k) .ne. 0) then + wrk(i,j,k,1:3) = zip + end if + end do + end do + end do +!-------------------------------------------------------------------------------- + + return + end subroutine les_rhs_velocity + +!================================================================================ +!================================================================================ +! Adding LES sources to the RHS of scalars +!================================================================================ + subroutine les_rhs_scalars + use x_fftw + implicit none + + integer :: n, i, j, k + + ! note that the turbulent viscosity itself is computed in rhs_scalars.f90 + ! here we only modify the RHSs for scalars in case we're running LES + + select case (les_model) +!-------------------------------------------------------------------------------- + case(1) + call m_les_rhss_turb_visc +!-------------------------------------------------------------------------------- + case(2) + ! -- Dynamic Localization model with algebraic model for dissipation + call m_les_k_src_dlm + call m_les_k_diss_algebraic + call m_les_rhss_turb_visc +!-------------------------------------------------------------------------------- + case(3) + ! -- Dynamic Localization model with lag-model for dissipation + call m_les_k_src_dlm + call m_les_lag_model_sources + call m_les_rhss_turb_visc +!-------------------------------------------------------------------------------- + case(4) + ! -- Dynamic Structure Model with algebraic model for dissipation + ! First taking care of the passive scalars (don't have them for now) + if (n_scalars .gt. 0) then + write(out,*) "*** Current version of the code cannot transport scalars" + write(out,*) "*** with the les_model=4 (Dynamic Structure Model)" + write(out,*) "Please specify a different LES model." + call flush(out) + call my_exit(-1) + end if + ! now taking care of the LES-related scalars + ! for the Dynamic Structure model, k-equation has turbulent viscosity + ! so need to add that term. + + call m_les_dstm_vel_k_sources + call m_les_k_diss_algebraic + call m_les_rhss_turb_visc +!-------------------------------------------------------------------------------- + case(5) + ! -- Dynamic Structure Model with lag-model for dissipation + ! First taking care of the passive scalars (don't have them for now) + if (n_scalars .gt. 0) then + write(out,*) "*** Current version of the code cannot transport scalars" + write(out,*) "*** with the les_model=5 (Dynamic Structure Model)" + write(out,*) "Please specify a different LES model." + call flush(out) + call my_exit(-1) + end if + ! now taking care of the LES-related scalars + ! for the Dynamic Structure model, k-equation has turbulent viscosity + ! so need to add that term. + + ! getting sources for velocities and production for k_s and B + call m_les_dstm_vel_k_sources + ! getting |S|^2 and putting it into wrk0 (for the timescale for B) + call m_les_k_src_dlm + ! getting the sources and sinks for (BT) and (eps T) and a sink for k_s + call m_les_lag_model_sources + ! diffusing k_s, (BT) and (epsilon*T) with turbulent viscosity + call m_les_rhss_turb_visc + +!-------------------------------------------------------------------------------- + case(6) + ! Mixed model (Dynamic Structure model + a fraction of Dynamic Localization model) + ! The fraction is given by the constant C_mixed, which is read from the file + ! This is taken care of in les_get_turb_visc + + ! First taking care of the passive scalars (don't have them for now) + if (n_scalars .gt. 0) then + write(out,*) "*** Current version of the code cannot transport scalars" + write(out,*) "*** with the les_model=6 (Mixed Model)" + write(out,*) "Please specify a different LES model." + call flush(out) + call my_exit(-1) + end if + ! now taking care of the LES-related scalars + ! for the mixed model, scalars and velocities have turbulent viscosity + ! so need to add that term. + + ! getting DSTM sources for velocities and production for k_sgs + call m_les_dstm_vel_k_sources + ! getting the DLM transfer term turb_visc*|S|^2 and adding to the RHS for k_sgs + call m_les_k_src_dlm + ! diffusing k_sgs with turbulent viscosity + call m_les_rhss_turb_visc + ! algebraic model for dissipation of k_sgs: k^{3/2}/Delta + call m_les_k_diss_algebraic + +!-------------------------------------------------------------------------------- + case(7) + ! Mixed model (Dynamic Structure model + a fraction of Dynamic Localization model) + ! The fraction is given by the constant C_mixed, which is read from the file + ! This is taken care of in les_get_turb_visc + + ! Dissipation is via lag model + + ! First taking care of the passive scalars (don't have them for now) + if (n_scalars .gt. 0) then + write(out,*) "*** Current version of the code cannot transport scalars" + write(out,*) "*** with the les_model=6 (Mixed Model)" + write(out,*) "Please specify a different LES model." + call flush(out) + call my_exit(-1) + end if + + ! now taking care of the LES-related scalars + ! for the Dynamic Structure model, k-equation has turbulent viscosity + ! so need to add that term. + + ! getting sources for velocities and production for k_s and B + call m_les_dstm_vel_k_sources + ! getting |S|^2 and putting it into wrk0 (for the timescale for B) + call m_les_k_src_dlm + ! getting the sources and sinks for (BT) and (eps T) and a sink for k_s + call m_les_lag_model_sources + ! diffusing k_s, (BT) and (epsilon*T) with turbulent viscosity + call m_les_rhss_turb_visc + +!-------------------------------------------------------------------------------- + case(10) + ! Mixed model (Dynamic Structure model + a fraction of Smagorinsky model) + ! The fraction is given by the constant C_mixed, which is read from the file + ! c_mixed.in + + ! Dissipation term in the k-equation is closed via lag-model + + ! first we add the turbulent diffusion to (BT) and (eps T) + ! (no turbulent diffusion for the passive scalars, since they are taken + ! care of by the Harlow model later) + call m_les_rhss_turb_visc1(3+n_scalars+1) + call m_les_rhss_turb_visc1(3+n_scalars+2) + + ! now calculate the SGS stress tauij and calculate the source term Pi + ! for (BT), the scalar with the number 3+n_scalars+1 + ! Add the source term for (BT) to the RHS for (BT) + ! Store the SGS stress in the array tauij. + call m_les_get_tauij_dstm_source_BT + + ! get the SGS fluxes for all passive scalars, using Harlow model + if (n_scalars.gt.0) call m_les_rhss_sgs_flux_harlow + + ! get the lag-model sources for (BT) and (eps T) and add those to RHSs + ! the "no_k" means that we calculate k_sgs as (BT)+(eps T), effectively + ! reducing the number of extra equations. + call m_les_lag_model_sources_no_k + +!-------------------------------------------------------------------------------- + case default + write(out,*) 'LES_RHS_SCALARS: invalid value of les_model:',les_model + call flush(out) + call my_exit(-1) + end select + +!-------------------------------------------------------------------------------- +! Making sure that we are not getting any aliasing errors. That is done by +! making RHS zero for wavenumbers that produce aliasing. +!-------------------------------------------------------------------------------- + do k = 1, nz + do j = 1, ny + do i = 1, nx + 2 + if (ialias(i,j,k) .ne. 0) then + wrk(i,j,k,4:3+n_scalars+n_les) = zip + end if + end do + end do + end do + +!-------------------------------------------------------------------------------- +! outputting the LES quantities in the file les.gp +!-------------------------------------------------------------------------------- + if(iammaster) then + if (mod(itime,iprint1)==0) then + open(999,file='les.gp', position='append') + if (n_les>0) then + if (les_model.lt.10) then + energy = fields(1,1,1,3+n_scalars+1) / real(nxyz_all) + else + energy = (fields(1,1,1,3+n_scalars+1) + fields(1,1,1,3+n_scalars+2))/ real(nxyz_all) + end if + write(999,"(i6,x,10e15.6)") itime, time, energy, production, B, dissipation + close(999) + end if + end if + B = zip + production = zip + dissipation = zip + end if +!-------------------------------------------------------------------------------- + return + end subroutine les_rhs_scalars + +!================================================================================ +!================================================================================ +! calculating LES sources for velocity field and adding them to the +! RHS's (wrk1...3) +!================================================================================ + subroutine les_rhsv_turb_visc + + use x_fftw + implicit none + + integer :: i, j, k, n + real(kind=8) :: rtmp + + ! due to memory constraints we have only three work arrays wrk4..6, + ! because the first three wrk1..3 contain already comptued velocity RHS's. + + ! Calculating S_11, S_12, S_13 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + ! S_11, du/dx + wrk(i ,j,k,4) = - akx(i+1) * fields(i+1,j,k,1) + wrk(i+1,j,k,4) = akx(i ) * fields(i ,j,k,1) + + ! S_12, 0.5 (du/dy + dv/dx) + wrk(i ,j,k,5) = -half * ( aky(k) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,2) ) + wrk(i+1,j,k,5) = half * ( aky(k) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,2) ) + + ! S_13, 0.5 (du/dz + dw/dx) + wrk(i ,j,k,6) = -half * ( akz(j) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,6) = half * ( akz(j) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,3) ) + end do + end do + end do + + ! Multiplying them by -2 * turbulent viscosity to get tau_11, tau_12, tau_13 + do n = 4,6 + call xFFT3d(-1,n) + wrk(1:nx,1:ny,1:nz,n) = - two * turb_visc(1:nx,1:ny,1:nz) * wrk(1:nx,1:ny,1:nz,n) + call xFFT3d(1,n) + end do + + ! Taking d/dx tau_11, d/dy tau_12, d/dz tau_13 and subtracting from the current RHS + ! note the sign reversal (-/+) because we subtract this from RHS + do k = 1, nz + do j = 1, ny + do i = 1, nx+1, 2 + + ! Cutting off any wave modes that can introduce aliasing into the velocities + ! This "dealiasing" is done in the most restrictive manner: only Fourier modes + ! that have ialias=0 are added + if (ialias(i,j,k) .eq. 0) then + + wrk(i ,j,k,1) = wrk(i ,j,k,1) + akx(i+1)*wrk(i+1,j,k,4) + aky(k)*wrk(i+1,j,k,5) + akz(j)*wrk(i+1,j,k,6) + wrk(i+1,j,k,1) = wrk(i+1,j,k,1) - akx(i )*wrk(i ,j,k,4) - aky(k)*wrk(i ,j,k,5) - akz(j)*wrk(i ,j,k,6) + + wrk(i ,j,k,2) = wrk(i ,j,k,2) + akx(i+1)*wrk(i+1,j,k,5) + wrk(i+1,j,k,2) = wrk(i+1,j,k,2) - akx(i )*wrk(i ,j,k,5) + + wrk(i ,j,k,3) = wrk(i ,j,k,3) + akx(i+1)*wrk(i+1,j,k,6) + wrk(i+1,j,k,3) = wrk(i+1,j,k,3) - akx(i )*wrk(i ,j,k,6) + + end if + + end do + end do + end do + + + ! Calculating S_22, S_23, S_33 + do k = 1, nz + do j = 1, ny + do i = 1, nx+1, 2 + + ! S_22, dv/dy + wrk(i ,j,k,4) = - aky(k) * fields(i+1,j,k,2) + wrk(i+1,j,k,4) = aky(k) * fields(i ,j,k,2) + + ! S_23, 0.5 (dv/dz + dw/dy) + wrk(i ,j,k,5) = - half * ( akz(j) * fields(i+1,j,k,2) + aky(k) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,5) = half * ( akz(j) * fields(i ,j,k,2) + aky(k) * fields(i ,j,k,3) ) + + ! S_33, de/dz + wrk(i ,j,k,6) = - akz(j) * fields(i+1,j,k,3) + wrk(i+1,j,k,6) = akz(j) * fields(i ,j,k,3) + end do + end do + end do + + ! Multiplying them by -2 * turbulent viscosity to get tau_22, tau_23, tau_33 + do n = 4,6 + call xFFT3d(-1,n) + wrk(1:nx,1:ny,1:nz,n) = - two * turb_visc(1:nx,1:ny,1:nz) * wrk(1:nx,1:ny,1:nz,n) + call xFFT3d(1,n) + end do + + ! Taking + ! d/dy tau_22, d/dz tau_23 + ! d/dy tau_23, d/dz tau_33 + ! and subtracting from the current RHS for v and w + ! note the sign reversal (-/+) because we subtract this from RHS + do k = 1, nz + do j = 1, ny + do i = 1, nx+1, 2 + + ! Cutting off any wave modes that can introduce aliasing into the velocities + ! This "dealiasing" is done in the most restrictive manner: only Fourier modes + ! that have ialias=0 are added + if (ialias(i,j,k) .eq. 0) then + wrk(i ,j,k,2) = wrk(i ,j,k,2) + aky(k)*wrk(i+1,j,k,4) + akz(j)*wrk(i+1,j,k,5) + wrk(i+1,j,k,2) = wrk(i+1,j,k,2) - aky(k)*wrk(i ,j,k,4) - akz(j)*wrk(i ,j,k,5) + + wrk(i ,j,k,3) = wrk(i ,j,k,3) + aky(k)*wrk(i+1,j,k,5) + akz(j)*wrk(i+1,j,k,6) + wrk(i+1,j,k,3) = wrk(i+1,j,k,3) - aky(k)*wrk(i ,j,k,5) - akz(j)*wrk(i ,j,k,6) + end if + + end do + end do + end do + + return + end subroutine les_rhsv_turb_visc + +!================================================================================ +!================================================================================ +! calculating LES sources for scalars and adding them to the RHS's +! wrk4...3+n_scalars+n_les +! +! case when SGS stress tau_ij is modeled using turbulent viscosity +! the turb. viscosity is supposed to be in the array turb_visc(nx,ny,nz) +!================================================================================ + subroutine m_les_rhss_turb_visc + implicit none + integer :: i + do i = 4, 3+n_scalars+n_les + call m_les_rhss_turb_visc1(i) + + end do + return + end subroutine m_les_rhss_turb_visc + +!================================================================================ +! Turbulent viscosity for one single field #n (or, scalar number n-3) +!================================================================================ + subroutine m_les_rhss_turb_visc1(n) + + use x_fftw + implicit none + + integer :: i, j, k, n, tmp1, tmp2 + character :: dir + + ! have two arrays available as work arrays: wrk 3+n_scalars+n_les+1 and +2 + tmp1 = 3 + n_scalars + n_les + 1 + tmp2 = 3 + n_scalars + n_les + 2 + + ! computing the second derivative, multiplying it by turb_visc + ! and adding to the RHS (that is contained in wrk(n)) + + wrk(:,:,:,tmp1) = fields(:,:,:,n) + wrk(:,:,:,0) = zip + + directions: do i = 1,3 + if (i.eq.1) dir = 'x' + if (i.eq.2) dir = 'y' + if (i.eq.3) dir = 'z' + + ! taking the first derivatite, multiplying by the turb_visc + ! then taking another derivative and adding the result to wrk0 + call x_derivative(tmp1, dir, tmp2) + call xFFT3d(-1,tmp2) + wrk(1:nx, 1:ny, 1:nz, tmp2) = wrk(1:nx, 1:ny, 1:nz, tmp2) * turb_visc(1:nx, 1:ny, 1:nz) + call xFFT3d(1,tmp2) + call x_derivative(tmp2, dir, tmp2) + + ! following Yoshizawa and Horiuti (1985), the viscosity in the scalar equation + ! is twice the viscosity used in the production of k_sgs + ! (Journal of Phys. Soc. Japan, V.54 N.8, pp.2834-2839) + ! wrk(1:nx, 1:ny, 1:nz, tmp2) = two * wrk(1:nx, 1:ny, 1:nz, tmp2) + + wrk(:,:,:,0) = wrk(:,:,:,0) + wrk(:,:,:,tmp2) + end do directions + + ! adding the d/dx ( nu_t d phi/dx) to the RHS for the scalar (field #n) + ! only adding the Fourier modes that are not producing any aliasing + do k = 1, nz + do j = 1, ny + do i = 1, nx+2 + if (ialias(i,j,k) .eq. 0) wrk(i,j,k,n) = wrk(i,j,k,n) + wrk(i,j,k,0) + end do + end do + end do + + return + end subroutine m_les_rhss_turb_visc1 + +!================================================================================ +!================================================================================ +! Calculation of turbulent viscosity turb_visc(:,:,:) +!================================================================================ + subroutine les_get_turb_visc + + implicit none + + select case (les_model) + case(1,4:5) + if (mod(itime,iprint1).eq.0) write(out,*) "Smagorinsky viscosity" + call flush(out) + call les_get_turb_visc_smag + + case(2:3) + call les_get_turb_visc_dlm + + case(6) + call les_get_turb_visc_smag + ! making turbulent viscosity a fraction of what it is since this is a + ! mixed model + turb_visc = C_mixed * turb_visc + + case(7) + call les_get_turb_visc_smag + ! making turbulent viscosity a fraction of what it is since this is a + ! mixed model + turb_visc = C_mixed * turb_visc + + case(10) + ! calculating the turbulent viscosity and saving the strain in the + ! array for the SGS stress + call les_get_turb_visc_smag_save_sij + + case default + write(out,*) "LES_GET_TURB_VISC: les_model: ", les_model + write(out,*) "LES_GET_TURB_VISC: Not calculating turb_visc" + call flush(out) + call my_exit(-1) + end select + + return + end subroutine les_get_turb_visc + + +!================================================================================ +! Calculation of turbulent viscosity turb_visc(:,:,:) - Smagorinsky model +!================================================================================ +!================================================================================ + subroutine les_get_turb_visc_smag + + use x_fftw + implicit none + + integer :: i, j, k, n + real*8 :: c_smag = 0.18_8 + + ! due to memory constraints we have only three work arrays wrk4..6, + ! because the first three wrk1..3 contain already comptued velocity RHS's. + + ! Calculating S_11, S_12, S_13 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + ! S_11, du/dx + wrk(i ,j,k,4) = - akx(i+1) * fields(i+1,j,k,1) + wrk(i+1,j,k,4) = akx(i ) * fields(i ,j,k,1) + + ! S_12, 0.5 (du/dy + dv/dx) + wrk(i ,j,k,5) = -half * ( aky(k) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,2) ) + wrk(i+1,j,k,5) = half * ( aky(k) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,2) ) + + ! S_13, 0.5 (du/dz + dw/dx) + wrk(i ,j,k,6) = -half * ( akz(j) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,6) = half * ( akz(j) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,3) ) + end do + end do + end do + + ! Converting them to real space and adding to turb_visc(:,:,:) + do n = 4,6 + call xFFT3d(-1,n) + end do + turb_visc(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,4)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,5)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,6)**2 + + ! Calculating S_22, S_23, S_33 + do k = 1, nz + do j = 1, ny + do i = 1, nx+1, 2 + + ! S_22, dv/dy + wrk(i ,j,k,4) = - aky(k) * fields(i+1,j,k,2) + wrk(i+1,j,k,4) = aky(k) * fields(i ,j,k,2) + + ! S_23, 0.5 (dv/dz + dw/dy) + wrk(i ,j,k,5) = - half * ( akz(j) * fields(i+1,j,k,2) + aky(k) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,5) = half * ( akz(j) * fields(i ,j,k,2) + aky(k) * fields(i ,j,k,3) ) + + ! S_33, dw/dz + wrk(i ,j,k,6) = - akz(j) * fields(i+1,j,k,3) + wrk(i+1,j,k,6) = akz(j) * fields(i ,j,k,3) + end do + end do + end do + + ! Converting them to real space and adding to turb_visc(:,:,:) + do n = 4,6 + call xFFT3d(-1,n) + end do + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + wrk(1:nx,1:ny,1:nz,4)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,5)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + wrk(1:nx,1:ny,1:nz,6)**2 + ! now turb_visc contains S_ij S_ij + + ! Finishing up the turbulent viscosiy + ! making it (C_s Delta)^2 |S|, where |S| = sqrt(2 S_{ij} S_{ij}) + turb_visc = sqrt( two * turb_visc) + turb_visc = turb_visc * (c_smag * les_delta)**2 + + return + end subroutine les_get_turb_visc_smag + +!================================================================================ +! Calculation of turbulent viscosity turb_visc(:,:,:) - Smagorinsky model +! Saving S_ij in the array tauij(:,:,:,:) for further needs. This is the only +! difference between this program and les_get_turb_visc_smag +!================================================================================ +!================================================================================ + subroutine les_get_turb_visc_smag_save_sij + + use x_fftw + implicit none + + integer :: i, j, k, n + real*8 :: c_smag = 0.18_8 + + ! due to memory constraints we have only three work arrays wrk4..6, + ! because the first three wrk1..3 contain already comptued velocity RHS's. + + ! Calculating S_11, S_12, S_13 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + ! S_11, du/dx + wrk(i ,j,k,4) = - akx(i+1) * fields(i+1,j,k,1) + wrk(i+1,j,k,4) = akx(i ) * fields(i ,j,k,1) + + ! S_12, 0.5 (du/dy + dv/dx) + wrk(i ,j,k,5) = -half * ( aky(k) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,2) ) + wrk(i+1,j,k,5) = half * ( aky(k) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,2) ) + + ! S_13, 0.5 (du/dz + dw/dx) + wrk(i ,j,k,6) = -half * ( akz(j) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,6) = half * ( akz(j) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,3) ) + end do + end do + end do + + ! Converting them to real space and adding to turb_visc(:,:,:) + do n = 4,6 + call xFFT3d(-1,n) + end do + turb_visc(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,4)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,5)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,6)**2 + + ! Saving S_11, S_12, S_13 + tauij(:,:,:,1) = wrk(:,:,:,4) + tauij(:,:,:,2) = wrk(:,:,:,5) + tauij(:,:,:,3) = wrk(:,:,:,6) + + ! Calculating S_22, S_23, S_33 + do k = 1, nz + do j = 1, ny + do i = 1, nx+1, 2 + + ! S_22, dv/dy + wrk(i ,j,k,4) = - aky(k) * fields(i+1,j,k,2) + wrk(i+1,j,k,4) = aky(k) * fields(i ,j,k,2) + + ! S_23, 0.5 (dv/dz + dw/dy) + wrk(i ,j,k,5) = - half * ( akz(j) * fields(i+1,j,k,2) + aky(k) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,5) = half * ( akz(j) * fields(i ,j,k,2) + aky(k) * fields(i ,j,k,3) ) + + ! S_33, dw/dz + wrk(i ,j,k,6) = - akz(j) * fields(i+1,j,k,3) + wrk(i+1,j,k,6) = akz(j) * fields(i ,j,k,3) + end do + end do + end do + + ! Converting them to real space and adding to turb_visc(:,:,:) + do n = 4,6 + call xFFT3d(-1,n) + end do + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + wrk(1:nx,1:ny,1:nz,4)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + two * wrk(1:nx,1:ny,1:nz,5)**2 + turb_visc(1:nx,1:ny,1:nz) = turb_visc(1:nx,1:ny,1:nz) + wrk(1:nx,1:ny,1:nz,6)**2 + ! now turb_visc contains S_ij S_ij + + ! Saving S_22, S_23, S_33 + tauij(:,:,:,4) = wrk(:,:,:,4) + tauij(:,:,:,5) = wrk(:,:,:,5) + tauij(:,:,:,6) = wrk(:,:,:,6) + ! now tauij(:,:,:,1:6) contains S_ij + + ! Finishing up the turbulent viscosiy + ! making it (C_s Delta)^2 |S|, where |S| = sqrt(2 S_{ij} S_{ij}) + turb_visc = sqrt( two * turb_visc) + turb_visc = turb_visc * (c_smag * les_delta)**2 + + return + end subroutine les_get_turb_visc_smag_save_sij + +!================================================================================ +!================================================================================ +! Calculation of turbulent viscosity turb_visc(:,:,:) - DLM model +!================================================================================ + subroutine les_get_turb_visc_dlm + + use x_fftw + implicit none + integer :: i,j,k + real*8 :: rkmax2, wmag2 + +!!$ real*8 :: C_k = 0.05d0 ! This is taken from Yoshizawa and Horiuti (1985) + real*8 :: C_k = 0.1d0 ! This is what works for this code. Dunno why... + real*8 :: sctmp, sctmp1 + +!!$ write(out,*) "Calculating turbulent viscosity using DLM model" +!!$ call flush(out) + + wrk(:,:,:,0) = fields(:,:,:,3+n_scalars+1) + +![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[ + rkmax2 = real(kmax**2,8) + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + wmag2 = akx(i)**2 + aky(k)**2 + akz(j)**2 + if (wmag2 .gt. rkmax2) wrk(i,j,k,0) = zip + end do + end do + end do +!]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] + + call xFFT3d(-1,0) + + ! C alculating the minimum value of k_sgs. If it's less that zero, clip it + ! at zero. + sctmp1 = minval(wrk(1:nx,1:ny,1:nz,0)) + count = 1 + call MPI_REDUCE(sctmp1,sctmp,count,MPI_REAL8,MPI_MIN,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(sctmp,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + if (iammaster) write(697,"(i6,x,e15.6)") itime, sctmp + if (iammaster .and. mod(itime,10).eq.0) call flush(697) +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + if (sctmp.lt.zip) then + ! write(out,*) 'LES_GET_TURB_VISC_DLM: minval of k is less than 0:',sctmp + ! call flush(out) + ! call my_exit(-1) + wrk(:,:,:,0) = max(wrk(:,:,:,0), zip) + end if + + turb_visc(1:nx,1:ny,1:nz) = C_k * les_delta * sqrt(wrk(1:nx,1:ny,1:nz,0)) + +!!$![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[ +!!$ if (mod(itime,iwrite4).eq.0) then +!!$ tmp4 = turb_visc +!!$ write(fname,"('nut1.',i6.6)") itime +!!$ call write_tmp4 +!!$ +!!$ tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,0) +!!$ write(fname,"('k1.',i6.6)") itime +!!$ call write_tmp4 +!!$ +!!$ end if +!!$!]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] + + ! If the minimum of k_sgs is less than zero, we want to clip it + ! mercilessly (already done in wrk0) then put it back in Fourier space + if (sctmp.lt.zip) then + call xFFT3d(1,0) + fields(:,:,:,3+n_scalars+1) = wrk(:,:,:,0) + end if + +!!$ write(out,*) " turbulent viscosity calculated" +!!$ call flush(out) + + return + end subroutine les_get_turb_visc_dlm + + +!================================================================================ +! Subroutine that initializes k_sgs for the Dynamic Localization Model (DLM) +!================================================================================ + subroutine m_les_dlm_k_init + + use x_fftw + implicit none + + integer :: i, j, k, n_k + + write(out,*) "m_les_dlm_k_init: initializing k_sgs" + call flush(out) + + n_k = 3 + n_scalars + 1 + fields(:,:,:,n_k) = zip + + ! initializing it as a constant + write(out,*) "m_les_dlm_k_init: initialized k=0.1" + call flush(out) + fields(:,:,:,n_k) = 0.1d0 + call xFFT3d_fields(1,n_k) + return + end subroutine m_les_dlm_k_init + +!================================================================================ +!================================================================================ +! Subroutine that calculates the source for k_sgs: - tau_{ij} S_{ij} +! for the case of Dynamic Localization Model (DLM) +! +! If called while les_model=5, then just calculate |S|^2 and put it into wrk0 +!================================================================================ + subroutine m_les_k_src_dlm + + use x_fftw + implicit none + integer :: n1, n2, k_n, i, j, k + + ! The source itself is nothing but 2 * nu_t * S_{ij} * S_{ij} + ! So the main hassle is to calculate S_{ij}, since nu_t is available from + ! the array turb_visc. + + ! have two arrays available as work arrays: wrk 3+n_scalars+n_les+1 and +2 + ! also have wrk0 in which we will assemble the source at the end + n1 = 3 + n_scalars + n_les + 1 + n2 = 3 + n_scalars + n_les + 2 + + wrk(:,:,:,0) = zip + wrk(:,:,:,n1) = zip + wrk(:,:,:,n2) = zip + + ! calculating the S_{ij} S_{ij}. Note that when calculating derivatives, + ! we only process those Fourier modes that won't introduce aliasing when + ! the quantity is squared. These modes are given by ialias(i,j,k)=0 + + ! calculating S_11, S_12 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + if (ialias(i,j,k).eq.0) then + ! S_11, du/dx + wrk(i ,j,k,n1) = - akx(i+1) * fields(i+1,j,k,1) + wrk(i+1,j,k,n1) = akx(i ) * fields(i ,j,k,1) + ! S_12, 0.5 (du/dy + dv/dx) + wrk(i ,j,k,n2) = -half * ( aky(k) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,2) ) + wrk(i+1,j,k,n2) = half * ( aky(k) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,2) ) + end if + end do + end do + end do + ! converting to real space, squaring and adding to wrk0 + call xFFT3d(-1,n1); call xFFT3d(-1,n2); + wrk(:,:,:,0) = wrk(:,:,:,0) + wrk(:,:,:,n1)**2 + two*wrk(:,:,:,n2)**2 + + ! calculating S_13, S_22 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + if(ialias(i,j,k).eq.0) then + ! S_13, 0.5 (du/dz + dw/dx) + wrk(i ,j,k,n1) = -half * ( akz(j) * fields(i+1,j,k,1) + akx(i+1) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,n1) = half * ( akz(j) * fields(i ,j,k,1) + akx(i ) * fields(i ,j,k,3) ) + ! S_22, dv/dy + wrk(i ,j,k,n2) = - aky(k) * fields(i+1,j,k,2) + wrk(i+1,j,k,n2) = aky(k) * fields(i ,j,k,2) + end if + end do + end do + end do + ! converting to real space, squaring and adding to wrk0 + call xFFT3d(-1,n1); call xFFT3d(-1,n2); + wrk(:,:,:,0) = wrk(:,:,:,0) + two*wrk(:,:,:,n1)**2 + wrk(:,:,:,n2)**2 + + ! calculating S_23, S_33 + do k = 1, nz + do j = 1, ny + do i = 1, nx + 1, 2 + if(ialias(i,j,k).eq.0) then + ! S_23, 0.5 (dv/dz + dw/dy) + wrk(i ,j,k,n1) = - half * ( akz(j) * fields(i+1,j,k,2) + aky(k) * fields(i+1,j,k,3) ) + wrk(i+1,j,k,n1) = half * ( akz(j) * fields(i ,j,k,2) + aky(k) * fields(i ,j,k,3) ) + ! S_33, dw/dz + wrk(i ,j,k,n2) = - akz(j) * fields(i+1,j,k,3) + wrk(i+1,j,k,n2) = akz(j) * fields(i ,j,k,3) + end if + end do + end do + end do + ! converting to real space, squaring and adding to wrk0 + call xFFT3d(-1,n1); call xFFT3d(-1,n2); + wrk(:,:,:,0) = wrk(:,:,:,0) + two*wrk(:,:,:,n1)**2 + wrk(:,:,:,n2)**2 + + ! at this point wrk0 contains S_{ij} S_{ij} in real space. + ! need to multiply by two and multiply by turb_visc to get the source + ! (the energy transfer term). Assemble the transfer term in wrk(n1). + ! NOTE: We do not touch wrk0 because we want to preserve S_{ij}S_{ij} + ! for other routines. + wrk(:,:,:,0) = two * wrk(:,:,:,0) + + ! if the subroutine is called with les_model=5, then the only part needed is the + ! calculation of the |S|^2 in wrk0. So now we check if les_model=5 and exit of it is + if (les_model.eq.5) return + + ! continue calculating the transfer term + wrk(:,:,:,n1) = wrk(:,:,:,0) + wrk(1:nx,1:ny,1:nz,n1) = wrk(1:nx,1:ny,1:nz,n1) * turb_visc(1:nx,1:ny,1:nz) + +!!$!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>DEBUG+ +!!$ ! writing out the energy transfer due to the viscosity +!!$ if (mod(itime,iwrite4).eq.0) then +!!$ tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,n1) +!!$ write(fname,"('pi_nu.',i6.6) ") itime +!!$ call write_tmp4 +!!$ end if +!!$!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>DEBUG- + + + + ! convert the transfer term to Fourier space + call xFFT3d(1,n1) + + ! adding this energy transfer term to the RHS for k_sgs + ! the RHS for k_sgs is supposed to be in wrk(3+n_scalars+1) + k_n = 3 + n_scalars + 1 + + ! saving the energy transfer to be output later + if (iammaster) production = production + wrk(1,1,1,n1) / real(nxyz_all) + + ! adding the source for k_sgs + do k = 1, nz + do j = 1, ny + do i = 1, nx + 2 + if (ialias(i,j,k).eq.0) wrk(i,j,k,k_n) = wrk(i,j,k,k_n) + wrk(i,j,k,n1) + end do + end do + end do + + ! if les_model=3 (DLM model + lag model for epsilon) + ! if les_model=7 (DSTM+DLM model + lag model for epsilon) + ! then add the source term to the RHS for B + if (les_model.eq.3 .or. les_model.eq.7) then + do k = 1, nz + do j = 1, ny + do i = 1, nx + 2 + if (ialias(i,j,k).eq.0) wrk(i,j,k,k_n+1) = wrk(i,j,k,k_n+1) + wrk(i,j,k,n1) + end do + end do + end do + end if + + return + end subroutine m_les_k_src_dlm + +!================================================================================ +!================================================================================ +! Dissipation term in k-equation: simple algebraic model k^(3/2)/Delta +!================================================================================ + subroutine m_les_k_diss_algebraic + + use x_fftw + implicit none + integer :: n_k, i, j, k + real*8 :: sctmp, sctmp1 + + ! the "field number" for k_sgs + n_k = 3 + n_scalars + 1 + + ! get the SGS kinetic energy in x-space + wrk(:,:,:,0) = fields(:,:,:,n_k) + + ! first zero the modes that can produce aliasing + do k = 1, nz + do j = 1, ny + do i = 1, nx+2 + if (ialias(i,j,k).gt.0) wrk(i,j,k,0) = zip + end do + end do + end do + ! then convert to x-space + call xFFT3d(-1,0) + + ! check the minimum value of k + sctmp1 = minval(wrk(1:nx,1:ny,1:nz,0)) + count = 1 + call MPI_REDUCE(sctmp1,sctmp,count,MPI_REAL8,MPI_MIN,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(sctmp,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) +!!$ if (sctmp.lt.zip) then +!!$ write(out,*) itime,"Minimum value of k is ", sctmp +!!$ call flush(out) +!!$ end if + + ! calculating the dissipation rate + wrk(:,:,:,0) = max(zip, wrk(:,:,:,0)) + wrk(:,:,:,0) = wrk(:,:,:,0)**1.5d0 / les_delta + call xFFT3d(1,0) + + ! subtracting the dissipation rate from the RHS for k + do k = 1, nz + do j = 1, ny + do i = 1, nx + if (ialias(i,j,k).eq.0) wrk(i,j,k,n_k) = wrk(i,j,k,n_k) - wrk(i,j,k,0) + end do + end do + end do +!!$ wrk(:,:,:,n_k) = wrk(:,:,:,n_k) - wrk(:,:,:,0) + + ! saving dissipation for output + if (iammaster) dissipation = dissipation + wrk(1,1,1,0) / real(nxyz_all) + + + return + end subroutine m_les_k_diss_algebraic + +!================================================================================ +!================================================================================ +! Model No. 3: +! - Dynamic Localization model for tau_{ij} with constant coefficients +! - Lag-model for the dissipation term (extra two equations) +! - turbulent viscosity for all scalars and velocities = sqr(k) * Delta +!================================================================================ +!================================================================================ + subroutine m_les_lag_model_sources + + use x_fftw + + implicit none + integer :: nk, n1, n2, i, j, k + + + ! the "field number" for k_sgs + nk = 3 + n_scalars + 1 + ! the numbers for two work arrays + n1 = 3 + n_scalars + n_les + 1 + n2 = 3 + n_scalars + n_les + 2 + + ! Getting B from (B T_B). + ! Currently T_B = 1/|S|, and |S|^2 is contained in wrk0 from m_les_k_src_dlm. + ! - getting (B T_B) to real space + wrk(:,:,:,n1) = fields(:,:,:,nk+1) + call xFFT3d(-1,n1) + ! - Dividing by T_B (multiplying by |S|) + wrk(:,:,:,n1) = wrk(:,:,:,n1) * sqrt(wrk(:,:,:,0)) + ! - converting back to Fourier space + call xFFT3d(1,n1) + + ! Getting epsilon from (epsilon T_epsilon) + wrk(:,:,:,n2) = fields(:,:,:,nk+2) + call xFFT3d(-1,n2) + ! Currently T_epsilon = C_T Delta^(2/3) / epsilon^(1/3). + ! Solving for epsilon: + wrk(:,:,:,n2) = max(wrk(:,:,:,n2), zip) + wrk(:,:,:,n2) = wrk(:,:,:,n2)**1.5D0 / (les_delta * C_T**1.5d0) + call xFFT3d(1,n2) + + ! saving B and dissipation for output later + if (iammaster) B = B + wrk(1,1,1,n1) / real(nxyz_all) + if (iammaster) dissipation = dissipation + wrk(1,1,1,n2) / real(nxyz_all) + + + ! Now we have B and epsilon, so we can update the RHS for k, B and epsilon + ! with the sources. The energy transfer term (Pi) was added to RHSs for + ! k and B in the m_les_k_src_dlm. Now adding the rest of the terms + + do k = 1, nz + do j = 1, ny + do i = 1, nx + 2 + if (ialias(i,j,k) .eq. 0) then + + ! updating the RHS for k_sgs (subtracting epsilon) + wrk(i,j,k,nk) = wrk(i,j,k,nk) - wrk(i,j,k,n2) + + ! updating the RHS for B (adding Pi and subtracting B) + ! note that Pi is already added in subroutines + ! m_les_dstm_vel_k_sources and m_les_k_src_dlm + wrk(i,j,k,nk+1) = wrk(i,j,k,nk+1) - wrk(i,j,k,n1) + + ! updating the RHS for epsilon (adding B and subtracting epsilon) + wrk(i,j,k,nk+2) = wrk(i,j,k,nk+2) + wrk(i,j,k,n1) - wrk(i,j,k,n2) + + end if + end do + end do + end do + + return + end subroutine m_les_lag_model_sources + + + +!================================================================================ +!================================================================================ +! Dynamic Structure Model for tau_{ij} +!================================================================================ +!================================================================================ + +!================================================================================ +! Subroutine that calculates the LES sources for the velocitieis +!================================================================================ + + subroutine m_les_dstm_vel_k_sources + + use x_fftw + use m_filter_xfftw + + implicit none + real*8 :: fac, rtmp1, rtmp2 + real*8 :: fs, fs1, bs, bs1 + integer :: n1, n2, n3, n4, n5 + integer :: nn, i, j, k, ii, jj, kk, nk + character :: dir_i, dir_j + logical :: diagonal + + + ! temporary array to store the complete k-source and write it out + real*4, allocatable :: k_source(:,:,:) + allocate(k_source(1:nx,1:ny,1:nz)) + + ! there are FIVE working arrays that we can use: wrk0 and + ! wrk(3+n_scalars+n_les+1....+4). The array n(:) will contain the indicies. + ! in comments we'll refer to the arrays as wrk1...5 + n1 = 0; + n2 = 3 + n_scalars + n_les + 1 + n3 = 3 + n_scalars + n_les + 2 + n4 = 3 + n_scalars + n_les + 3 + n5 = 3 + n_scalars + n_les + 4 + nk = 3 + n_scalars + 1 + + ! converting k_sgs to x-space and placing it in wrk1 + wrk(:,:,:,n1) = fields(:,:,:,nk) + + call xFFT3d(-1,n1) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + ! compute the minimum value of k + rtmp1 = minval(wrk(1:nx,:,:,n1)) + count = 1 + call MPI_REDUCE(rtmp1,rtmp2,count,MPI_REAL8,MPI_MIN,0,MPI_COMM_TASK,mpi_err) + if (myid.eq.0 .and. mod(itime,iprint1).eq.0) then + write(699,"(i6,x,e15.6)") itime, rtmp2 + call flush(699) + end if +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + ! Assembling first part of L_ii in wrk2 + wrk(:,:,:,n3) = fields(:,:,:,1) + wrk(:,:,:,n4) = fields(:,:,:,2) + wrk(:,:,:,n5) = fields(:,:,:,3) + call xFFT3d(-1,n3) + call xFFT3d(-1,n4) + call xFFT3d(-1,n5) + wrk(:,:,:,n2) = wrk(:,:,:,n3)**2 + wrk(:,:,:,n4)**2 + wrk(:,:,:,n5)**2 + call xFFT3d(1,n2) + call filter_xfftw(n2) + call xFFT3d(-1,n2) + + ! Putting u, v, w in wrk3..5 and filtering them + wrk(:,:,:,n3) = fields(:,:,:,1) + wrk(:,:,:,n4) = fields(:,:,:,2) + wrk(:,:,:,n5) = fields(:,:,:,3) + call filter_xfftw(n3) + call filter_xfftw(n4) + call filter_xfftw(n5) + call xFFT3d(-1,n3) + call xFFT3d(-1,n4) + call xFFT3d(-1,n5) + + ! Now subtracting the second part of L_ii into wrk2. + wrk(:,:,:,n2) = wrk(:,:,:,n2) & + - wrk(:,:,:,n3)**2 - wrk(:,:,:,n4)**2 - wrk(:,:,:,n5)**2 + + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + if (mod(itime,iwrite4).eq.0) then + tmp4(1:nx,:,:) = wrk(1:nx,:,:,n1) + write(fname,"('k.',i6.6)") itime + call write_tmp4 + tmp4(1:nx,:,:) = wrk(1:nx,:,:,n2) + write(fname,"('L.',i6.6)") itime + call write_tmp4 + end if +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + + ! now put the scaling factor of the DStM in wrk1 + ! the scaling factor is 2*k/L_ii +!wrk(:,:,:,n1) = two * wrk(:,:,:,n1) / max(wrk(:,:,:,n2),1.d-15) +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG+ + ! Now we want to clip the scaling factor to be non-negative. + ! This is done in order to make the energy transfer from the DSTM + ! non-negative at the places where k_sgs = 0. + ! Basically we shut down the DSTM energy transfer where k<=0 + ! and let the diffusion work. + ! + ! Formixed models, the viscous part of the model should provide + ! enough positive energy transfer to over come the nagetiveness. + ! Although that does not happen as fast as we want. + wrk(:,:,:,n1) = two * max(wrk(:,:,:,n1),zip) / max(wrk(:,:,:,n2),1.d-15) +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG- + + + + if (mod(itime,iwrite4).eq.0) then + tmp4(1:nx,:,:) = wrk(1:nx,:,:,n1) + write(fname,"('F.',i6.6)") itime + call write_tmp4 + end if + + ! now going over tau_{ij} and S_{ij}, term by term. + ! cycling over i and j. I know this is inefficient but this results in + ! the minimal amount of code to debud and I don't have much time to + ! optimize the performance right now. + + ! when calculated, the LES source/sink terms for velocities are placed in + ! the special array vel_source_les(:,:,:,:) + vel_source_les = zip + + k_source = zip + + ! forward/backward scatter + fs = zip + fs1 = zip + bs = zip + bs1 = zip + + ! cycling over i and j + direction_i: do i = 1,3 + + if (i.eq.1) dir_i = 'x' + if (i.eq.2) dir_i = 'y' + if (i.eq.3) dir_i = 'z' + + direction_j: do j = 1,3 + + if (j.eq.1) dir_j = 'x' + if (j.eq.2) dir_j = 'y' + if (j.eq.3) dir_j = 'z' + + wrk(:,:,:,n2) = fields(:,:,:,i) + wrk(:,:,:,n3) = fields(:,:,:,j) + wrk(:,:,:,n4) = fields(:,:,:,i) + wrk(:,:,:,n5) = fields(:,:,:,j) + call xFFT3d(-1,n2) + call xFFT3d(-1,n3) + call filter_xfftw(n4) + call filter_xfftw(n5) + call xFFT3d(-1,n4) + call xFFT3d(-1,n5) + + ! hat(u_i u_j) -> wrk2 + wrk(:,:,:,n2) = wrk(:,:,:,n2) * wrk(:,:,:,n3) + call xFFT3d(1,n2) + call filter_xfftw(n2) + call xFFT3d(-1,n2) + + ! L_{ij} -> wrk2 + wrk(:,:,:,n2) = wrk(:,:,:,n2) - wrk(:,:,:,n4) * wrk(:,:,:,n5) + + ! tau_{ij} -> wrk2 + wrk(:,:,:,n2) = wrk(:,:,:,n2) * wrk(:,:,:,n1) + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG + + ! writing out tau_{ij} + if (mod(itime,iwrite4).eq.0) then + tmp4(1:nx,:,:) = wrk(1:nx,:,:,n2) + write(fname,"('tau',i1,i1,'.',i6.6)") i,j,itime + call write_tmp4 + end if +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG - + + + ! The source in k-equation is really - du_i/dx_j * tau_{ij} + wrk(:,:,:,n3) = fields(:,:,:,i) + call x_derivative(n3,dir_j,n3) + call xFFT3d(-1,n3) + wrk(:,:,:,n5) = - wrk(:,:,:,n3) * wrk(:,:,:,n2) + + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG + + k_source(:,:,:) = k_source(:,:,:) + wrk(1:nx,:,:,n5) +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG - + + ! converting both tau_{ij} and souce for k_sgs to Fourier space + call xFFT3d(1,n2) + call xFFT3d(1,n5) + + ! calculating source for velocities u_i and u_j: + ! for u_i : - d/dx_j tau_{ij} -> wrk3 +!!$ ! for u_j : - d/dx_i tau_{ij} -> wrk4 + wrk(:,:,:,n3) = - wrk(:,:,:,n2) +!!$ wrk(:,:,:,n4) = - wrk(:,:,:,n2) + call x_derivative(n3,dir_j,n3) +!!$ call x_derivative(n4,dir_i,n4) + + ! now adding the sources to the RHSs + ! adding only the wavenumbers that do not produce aliasing + adding_sources: do kk = 1,nz + do jj = 1,ny + do ii = 1,nx+2 + if (ialias(ii,jj,kk).eq.0) then + + ! velocity sources + vel_source_les(ii,jj,kk,i) = vel_source_les(ii,jj,kk,i) + wrk(ii,jj,kk,n3) + ! k_source + wrk(ii,jj,kk,nk) = wrk(ii,jj,kk,nk) + wrk(ii,jj,kk,n5) + ! B-source due to the DSTM (for models #5 and #7) + if (les_model.eq.5 .or. les_model.eq.7) then + wrk(ii,jj,kk,nk+1) = wrk(ii,jj,kk,nk+1) + wrk(ii,jj,kk,n5) + end if + +!!$ ! if i.ne.j that is, we need to add some more stuff +!!$ if (j > i) then +!!$ ! velocity sources +!!$ vel_source_les(ii,jj,kk,j) = vel_source_les(ii,jj,kk,j) + wrk(ii,jj,kk,n4) +!!$ ! k_source +!!$ wrk(ii,jj,kk,nk) = wrk(ii,jj,kk,nk) + wrk(ii,jj,kk,n5) +!!$ ! B-source (for model #5) +!!$ if (les_model.eq.5) then +!!$ wrk(ii,jj,kk,nk+1) = wrk(ii,jj,kk,nk+1) + wrk(ii,jj,kk,n5) +!!$ end if +!!$ end if + + end if + end do + end do + end do adding_sources + +!!$ if (iammaster) then +!!$ write(720+3*(j-1)+i,"(i6,x,10e15.6)") itime, vel_source_les(1,1,1,:) +!!$ call flush(720+3*(j-1)+i) +!!$ end if + + + ! saving production for output + if (iammaster) production = production + wrk(1,1,1,n5) / real(nxyz_all) +!!$ if (iammaster .and. j>i) production = production + wrk(1,1,1,n5) / real(nxyz_all) + + ! doing the budget: counting the positive and negative production + ! (i.e., forward and backward scatter) + call xFFT3d(-1,n5) + do kk=1,nz + do jj = 1,ny + do ii = 1,nx + if (wrk(ii,jj,kk,n5) .gt. zip) then + fs1 = fs1 + wrk(ii,jj,kk,n5) + else + bs1 = bs1 + wrk(ii,jj,kk,n5) + end if + end do + end do + end do + + +!!$! -------------------------------------------------- +!!$ wrk(:,:,:,n5) = wrk(:,:,:,3+n_scalars+1) +!!$ call xFFT3d(-1,n5) +!!$ tmp4(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,n5) +!!$ write(fname,"('source',i1,i1)") i,j +!!$ call write_tmp4 +!!$! -------------------------------------------------- + + + + end do direction_j + end do direction_i + + ! writing out int he file fort.698 forward scatter, back scatter produced by the DSTM + count = 1 + call MPI_REDUCE(fs1,fs,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + call MPI_REDUCE(bs1,bs,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + if (myid.eq.0 .and. mod(itime,iprint1).eq.0) then + fs = fs / real(nxyz_all,8) + bs = bs / real(nxyz_all,8) + write(698,"(i6,x,3e15.6)") itime, fs, bs + call flush(698) + end if + +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG + + ! writing out k_source + if (mod(itime,iwrite4).eq.0) then + tmp4 = k_source + write(fname,"('pi.',i6.6)") itime + call write_tmp4 + end if +!<><><><><><><><><><><><><><><><><><><><><><><><><><><><><> DEBUG - + + + if (allocated(k_source)) deallocate(k_source) + + end subroutine m_les_dstm_vel_k_sources + + +!================================================================================ +!================================================================================ +! Calculating the subgrid stress tauij(:,:,:,:) using mixed model: DSTM+C_m*SM. +! Assume that the SGS dissipation is closed using the lag-model. +! Using the fact that S_ij is calculated prior to calling this subroutine +! and is stored in the array tauij, we calculate the source term +! for (BT), the scalar number 3+n_scalars+1, and add it to the RHS for (BT). +!================================================================================ + subroutine m_les_get_tauij_dstm_source_BT + + use m_filter_xfftw + + implicit none + integer :: n1, n2, n3, n4, n5 + integer :: n, i, j, k + integer :: n_bt, n_et + + ! there are FIVE working arrays that we can use: wrk0 and + ! wrk(3+n_scalars+n_les+1....+4). We use indicies n1,...,n5 + ! in comments we'll refer to the arrays as wrk1...5 + n1 = 0; + n2 = 3 + n_scalars + n_les + 1 + n3 = 3 + n_scalars + n_les + 2 + n4 = 3 + n_scalars + n_les + 3 + n5 = 3 + n_scalars + n_les + 4 + + ! the numbers for the field (BT) + n_bt = 3 + n_scalars + 1 + n_et = 3 + n_scalars + 2 + + ! L_11, L_22, L_33 -> wrk1, wrk2, wrk3 + do i = 1,3 + wrk(:,:,:,n4) = fields(:,:,:,i) + call xFFT3d(-1,n4) + wrk(:,:,:,n4) = wrk(:,:,:,n4)**2 + call xFFT3d(1,n4) + call filter_xfftw(n4) + call xFFT3d(-1,n4) + + wrk(:,:,:,n5) = fields(:,:,:,i) + call filter_xfftw(n5) + call xFFT3d(-1,n5) + + ! putting L_ii (no summation implied) in wrk(i) + if (i.eq.1) n = n1 + if (i.eq.2) n = n2 + if (i.eq.3) n = n3 + wrk(:,:,:,n) = wrk(:,:,:,n4) - wrk(:,:,:,n5)**2 + end do + + ! putting the trace of L_ij, L_ii (summation implied) into wrk4 + wrk(:,:,:,n4) = wrk(:,:,:,n1) + wrk(:,:,:,n2) + wrk(:,:,:,n3) + + ! putting k_sgs into wrk5 and converting it to x-space + ! note that k_sgs in this model is the sum (BT) + (eps T) + wrk(:,:,:,n5) = fields(:,:,:,n_bt) + fields(:,:,:,n_et) + call xFFT3d(-1,n5) + + ! compute the scaling factor 2*k_sgs/L_kk, and put it into wrk4 + do k = 1,nz + do j = 1,ny + do i = 1,nx + if (wrk(i,j,k,n4) .lt. 1e-10) then + wrk(i,j,k,n4) = zip + else + wrk(i,j,k,n4) = two * wrk(i,j,k,n5) / wrk(i,j,k,n4) + end if + end do + end do + end do + + ! now we want to do two things simultaneously: + ! 1) compute tau_ij = 2k_sgs/L_kk L_ij - C_mixed * 2 * turb_visc * S_ij + ! 2) compute the energy transfer term tau_ij S_ij + ! the way to do this: + ! - for each ij, compute -L_ij S_ij and add it to wrk5 + ! - after that compute the true tau_ij and put it in tauij(...) + ! - when all indicies (ij) are processed, multiply the wrk5 by wrk4 (scaling factor) + ! - after that add C_mixed turb_visc |S|^2 to wrk5 + ! thus the array tauij will contain tau_ij (full version, both parts of the mixed model) + ! and wrk5 will contain -(tau_ij S_ij) = Pi, the energy transfer term + + ! computing the diagonal elements of tauij + ! note that right now tauij contains the elements of S_ij + ! and S_ij should be a part of tauij. Thus the memory acrobatics. + + ! putting -(L_ij S_ij) into wrk5 (only diagonal elements so far) + wrk(:,:,:,n5) = & + - wrk(:,:,:,n1) * tauij(:,:,:,1) & + - wrk(:,:,:,n2) * tauij(:,:,:,4) & + - wrk(:,:,:,n3) * tauij(:,:,:,6) + + ! computing the diagonal elements of tau_ij + tauij(1:nx,:,:,1) = & + wrk(1:nx,:,:,n4) * wrk(1:nx,:,:,n1) - & + C_mixed * two * turb_visc(1:nx,:,:) * tauij(1:nx,:,:,1) + tauij(1:nx,:,:,4) = & + wrk(1:nx,:,:,n4) * wrk(1:nx,:,:,n2) - & + C_mixed * two * turb_visc(1:nx,:,:) * tauij(1:nx,:,:,4) + tauij(1:nx,:,:,6) = & + wrk(1:nx,:,:,n4) * wrk(1:nx,:,:,n3) - & + C_mixed * two * turb_visc(1:nx,:,:) * tauij(1:nx,:,:,6) + + ! currently wrk4 has the scaling factor from DSTM model: (2k_sgs/L_kk) + ! and wrk5 has the part of the energy transfer term given by DSTM model + ! (only diagonal terms so far), + ! not the whole mixed model + ! this means that the free arrays are wrk1...3 + + ! computing the off-diagonal parts of tau_ij and their contribution to the energy tansfer + ! the index n will be the corresponding index in the tauij array, since + ! the elements of tauij are : tau_11, tau_12, 13, 22, 23, 33. + + ! NOTE: This is done in an inefficient way, with a good possibility of a speedup + ! because filtering of all velocities is done twice. + + n = 0 + do i = 1,3 + do j = i,3 + n = n + 1 + if (i.lt.j) then + + ! computing L_ij + wrk(:,:,:,n1) = fields(:,:,:,i) + wrk(:,:,:,n2) = fields(:,:,:,j) + call xFFT3d(-1,n1) + call xFFT3d(-1,n2) + wrk(:,:,:,n1) = wrk(:,:,:,n1) * wrk(:,:,:,n2) + call xFFT3d(1,n1) + call filter_xfftw(n1) + call xFFT3d(-1,n1) + + wrk(:,:,:,n2) = fields(:,:,:,i) + wrk(:,:,:,n3) = fields(:,:,:,j) + call filter_xfftw(n2) + call filter_xfftw(n3) + call xFFT3d(-1,n2) + call xFFT3d(-1,n3) + + ! calculating L_ij + wrk(:,:,:,n1) = wrk(:,:,:,n1) - wrk(:,:,:,n2) * wrk(:,:,:,n3) + + ! adding the (-L_ij S_ij) to the transfer term in wrk5 + ! note that since these are off-diagonal terms, they enter the + ! summation twice, thus we need to multiply them by two + wrk(:,:,:,n5) = wrk(:,:,:,n5) - two * wrk(:,:,:,n1) * tauij(:,:,:,n) + + ! computing the full tau_ij and putting it into tauij(n) + tauij(1:nx,:,:,n) = & + wrk(1:nx,:,:,n4) * wrk(1:nx,:,:,n1) - & + C_mixed * two * turb_visc(1:nx,:,:) * tauij(1:nx,:,:,n) + + end if + end do + end do + + ! now tauij(1..6) contain the full mixed model for tau_ij + ! and wrk5 contains the sum: -L_ij S_ij + ! to compute the full energy transfer term we need to multiply wrk5 by + ! the scalaing factor first and then add + ! C_mixed * turb_visc * |S|^2. Since the expression for turb_visc + ! contains |S|, we can algebraically solve for |S| and add the missing + ! part without re-calculating S_ij. + + ! multiplying wrk5 by the scaling factor + wrk(:,:,:,n5) = wrk(:,:,:,n5) * wrk(:,:,:,n4) + + ! adding the part of Pi that comes from the viscous part of the model for tau_ij + wrk(1:nx,:,:,n5) = wrk(1:nx,:,:,n5) + C_mixed * turb_visc(1:nx,:,:)**3 / (c_smag*les_delta)**4 + + ! converting the energy transfer to F-space and adding to the RHS for (BT) + call xFFT3d(1,n5) + wrk(:,:,:,n_bt) = wrk(:,:,:,n_bt) + wrk(:,:,:,n5) + + ! saving the mean energy transfer for statistics file + if (iammaster) production = wrk(1,1,1,n5) / real(nxyz_all) + + return + end subroutine m_les_get_tauij_dstm_source_BT + + +!================================================================================ +!================================================================================ +! Calculate the SGS fluxes for all scalars using Harlow model. +! The timescale is 1/|S|. |S| is taken from the turbulent viscosity that was +! calculated earlier and is in the array turb_visc. The formula for turb_visc: +! turb_visc = (c_smag * Delta)^2 |S| +! The formula for the SGS flux of a scalar using Harlow model is +! flux = d/dx ( 1/|S| tau_ij d(phi)/dx_i ) +!================================================================================ + subroutine m_les_rhss_sgs_flux_harlow + + implicit none + + integer :: n, n1, n2, n3, n4, n5 + integer :: i, j, k + + ! these five work arrays are free, so we're using them + n1 = 0; + n2 = 3 + n_scalars + n_les + 1 + n3 = 3 + n_scalars + n_les + 2 + n4 = 3 + n_scalars + n_les + 3 + n5 = 3 + n_scalars + n_les + 4 + + ! first, get the |S| from the turb_visc array and put it in wrk5 + wrk(1:nx,:,:,n5) = turb_visc(1:nx,:,:) / (c_smag * les_delta)**2 + ! inverting it so we have the timescale 1/|S| + do k = 1,nz + do j = 1,ny + do i = 1,nx + if (abs(wrk(i,j,k,n5)) .lt. 1e-10) then + wrk(i,j,k,n5) = zip + else + wrk(i,j,k,n5) = 1.d0 / wrk(i,j,k,n5) + end if + end do + end do + end do + ! now wrk5 contains the timescale for the Harlow model + + ! Calculating the SGS fluxes for scalars. + ! The active scalars (BT) and (eps T) do not need SGS transport, because the SGS transport + ! does not enter the equation for k_sgs. + + ! doing one scalar at a time + sgs_fluxes_scalars: do n = 1, n_scalars + + ! get all derivatives of the scalar + wrk(:,:,:,n1) = fields(:,:,:,3+n) + call x_derivative(n1,'z',n3) + call x_derivative(n1,'y',n2) + call x_derivative(n1,'x',n1) + ! convert them to X-space + call xFFT3d(-1,n1) + call xFFT3d(-1,n2) + call xFFT3d(-1,n3) + + ! component by component, calculate the vector tau_ij d(phi)/dx_j + ! multiply it by the timescale + ! take the derivative d/dx_i + ! add to the RHS of the scalar transport equation + + ! i = 1 + wrk(:,:,:,n4) = tauij(:,:,:,1)*wrk(:,:,:,n1) + tauij(:,:,:,2)*wrk(:,:,:,n2) + tauij(:,:,:,3)*wrk(:,:,:,n3) + wrk(:,:,:,n4) = wrk(:,:,:,n4) * wrk(:,:,:,n5) + call xFFT3d(1,n4) + call x_derivative(n4,'x',n4) + ! adding to the RHS + wrk(:,:,:,3+n) = wrk(:,:,:,3+n) + wrk(:,:,:,n4) + + ! i = 2 + wrk(:,:,:,n4) = tauij(:,:,:,2)*wrk(:,:,:,n1) + tauij(:,:,:,4)*wrk(:,:,:,n2) + tauij(:,:,:,5)*wrk(:,:,:,n3) + wrk(:,:,:,n4) = wrk(:,:,:,n4) * wrk(:,:,:,n5) + call xFFT3d(1,n4) + call x_derivative(n4,'y',n4) + ! adding to the RHS + wrk(:,:,:,3+n) = wrk(:,:,:,3+n) + wrk(:,:,:,n4) + + ! i = 3 + wrk(:,:,:,n4) = tauij(:,:,:,3)*wrk(:,:,:,n1) + tauij(:,:,:,5)*wrk(:,:,:,n2) + tauij(:,:,:,6)*wrk(:,:,:,n3) + wrk(:,:,:,n4) = wrk(:,:,:,n4) * wrk(:,:,:,n5) + call xFFT3d(1,n4) + call x_derivative(n4,'z',n4) + ! adding to the RHS + wrk(:,:,:,3+n) = wrk(:,:,:,3+n) + wrk(:,:,:,n4) + + end do sgs_fluxes_scalars + + return + end subroutine m_les_rhss_sgs_flux_harlow +!================================================================================ +!================================================================================ +! Sources for the lag-model quantities (BT) and (eps*T) that arise from the +! lag-model: +! * for (BT) the source is (-B) +! * for (eps T) the sources are (+ B) and (- eps) +! +! This version caters to the model that does NOT have a separate transport +! equation for k_sgs. Thus the number are +! 3+n_scalars+1 for (BT), and 3+n_scalars+2 for (eps*T) +!================================================================================ + subroutine m_les_lag_model_sources_no_k + + use x_fftw + + implicit none + integer :: n, n1, n2, n3, n4, n5, n_bt, n_et + integer :: i, j, k + + ! these five work arrays are free, so we're using them + n1 = 0; + n2 = 3 + n_scalars + n_les + 1 + n3 = 3 + n_scalars + n_les + 2 + n4 = 3 + n_scalars + n_les + 3 + n5 = 3 + n_scalars + n_les + 4 + + ! the number for BT and (eps T) + n_bt = 3 + n_scalars + 1 + n_et = 3 + n_scalars + 2 + + + ! Currently T_B = 1/|S|. We need the inverse, which is |S|. + ! compute it from turb_visc = (C_smag * les_delta)**2 * |S| + wrk(1:nx,:,:,n5) = turb_visc(1:nx,:,:) / (C_smag * les_delta)**2 + + ! Getting B from (B T_B). + ! - getting (B T_B) to real space + wrk(:,:,:,n1) = fields(:,:,:,n_bt) + call xFFT3d(-1,n1) + ! - Dividing by T_B (multiplying by |S|) + wrk(:,:,:,n1) = wrk(:,:,:,n1) * wrk(:,:,:,n5) + ! - converting back to Fourier space + call xFFT3d(1,n1) + + ! Getting epsilon from (epsilon T_epsilon) + wrk(:,:,:,n2) = fields(:,:,:,n_et) + call xFFT3d(-1,n2) + ! Currently T_epsilon = C_T Delta^(2/3) / epsilon^(1/3). + ! Solving for epsilon: + wrk(:,:,:,n2) = max(wrk(:,:,:,n2), zip) + wrk(:,:,:,n2) = wrk(:,:,:,n2)**1.5D0 / (les_delta * C_T**1.5d0) + call xFFT3d(1,n2) + + ! Now we have B and epsilon, so we can update the RHS for (BT) and (eps * T) + ! with the sources. + + ! updating the RHS for B (subtracting B) + wrk(:,:,:,n_bt) = wrk(:,:,:,n_bt) - wrk(:,:,:,n1) + + ! updating the RHS for (epsilon T) (adding B and subtracting epsilon) + wrk(:,:,:,n_et) = wrk(:,:,:,n_et) + wrk(:,:,:,n1) - wrk(:,:,:,n2) + + ! saving B and dissipation for output later + if (iammaster) B = wrk(1,1,1,n1) / real(nxyz_all) + if (iammaster) dissipation = wrk(1,1,1,n2) / real(nxyz_all) + + return + end subroutine m_les_lag_model_sources_no_k + +!================================================================================ +!================================================================================ +! Calculate the LES velocity sources from the array tauij(:,:,:,:) +!================================================================================ + subroutine les_add_vel_source_from_tauij + + implicit none + integer :: n, n1, n2, n3, n4, n5 + integer :: i, j, k + + ! these five work arrays are free, so we're using them + n1 = 0; + n2 = 3 + n_scalars + n_les + 1 + n3 = 3 + n_scalars + n_les + 2 + n4 = 3 + n_scalars + n_les + 3 + n5 = 3 + n_scalars + n_les + 4 + + ! First get tauij in Fourier space, all of them + do n = 1, 6 + wrk(:,:,:,n1) = tauij(:,:,:,n) + call xFFT3d(1,n1) + tauij(:,:,:,n) = wrk(:,:,:,n1) + end do + + ! Source for u + wrk(:,:,:,n1) = tauij(:,:,:,1) + wrk(:,:,:,n2) = tauij(:,:,:,2) + wrk(:,:,:,n3) = tauij(:,:,:,3) + call x_derivative(n1,'x',n1) + call x_derivative(n2,'y',n2) + call x_derivative(n3,'z',n3) + wrk(:,:,:,1) = wrk(:,:,:,1) - wrk(:,:,:,n1) - wrk(:,:,:,n2) - wrk(:,:,:,n3) + + ! Source for v + wrk(:,:,:,n1) = tauij(:,:,:,2) + wrk(:,:,:,n2) = tauij(:,:,:,4) + wrk(:,:,:,n3) = tauij(:,:,:,5) + call x_derivative(n1,'x',n1) + call x_derivative(n2,'y',n2) + call x_derivative(n3,'z',n3) + wrk(:,:,:,2) = wrk(:,:,:,2) - wrk(:,:,:,n1) - wrk(:,:,:,n2) - wrk(:,:,:,n3) + + ! Source for w + wrk(:,:,:,n1) = tauij(:,:,:,3) + wrk(:,:,:,n2) = tauij(:,:,:,5) + wrk(:,:,:,n3) = tauij(:,:,:,6) + call x_derivative(n1,'x',n1) + call x_derivative(n2,'y',n2) + call x_derivative(n3,'z',n3) + wrk(:,:,:,3) = wrk(:,:,:,3) - wrk(:,:,:,n1) - wrk(:,:,:,n2) - wrk(:,:,:,n3) + + return + end subroutine les_add_vel_source_from_tauij + +!================================================================================ +!================================================================================ +end module m_les diff --git a/m_openmpi.f90 b/m_openmpi.f90 new file mode 100644 index 0000000..d0c8fee --- /dev/null +++ b/m_openmpi.f90 @@ -0,0 +1,250 @@ +!================================================================================ +! Module contains interface to OpenMPI +! +! Time-stamp: <2009-08-20 14:22:13 (chumakov)> +!================================================================================ + + +module m_openmpi +!================================================================================ + implicit none + include 'mpif.h' + + ! Uncomment this for the systems that do not have OpenMPI + ! In OpenMPI, the parameter MPI_INTEGER_KIND is defined in 'mpif.h' + ! With other MPI implementations, this parameter has to be defined manually. + integer MPI_INTEGER_KIND + parameter (MPI_INTEGER_KIND = 4) + + ! --- MPI variables + logical :: iammaster + integer(kind=MPI_INTEGER_KIND) :: myid_world, numprocs_world + integer(kind=MPI_INTEGER_KIND) :: numprocs_hydro, numprocs_stats, numprocs_parts + integer(kind=MPI_INTEGER_KIND) :: myid, numprocs, master, mpi_err, mpi_info + integer(kind=MPI_INTEGER_KIND) :: id_to, id_from, tag, count + integer(kind=MPI_INTEGER_KIND) :: id_root_hydro, id_root_stats, id_root_parts + + ! communicator for separate tasks + integer(kind=MPI_INTEGER_KIND) :: MPI_COMM_TASK + ! exclusive communicator for root processes of tasks + integer(kind=MPI_INTEGER_KIND) :: MPI_COMM_ROOTS + + integer (kind=MPI_INTEGER_KIND) :: sendtag, recvtag + integer (kind=MPI_INTEGER_KIND) :: request, request1, request2, request3, mpi_request + integer (kind=MPI_INTEGER_KIND) :: id_l, id_r + integer (kind=mpi_INTEGER_KIND) :: mpi_status(MPI_STATUS_SIZE) + + integer(kind=MPI_INTEGER_KIND) :: color, key + + character*5 :: task, split="nevah" + character*10 :: run_name_local + + logical :: task_split=.false. + +!================================================================================ +contains +!================================================================================ + + subroutine m_openmpi_init + + implicit none + + integer (kind=mpi_INTEGER_KIND) :: n + integer*4 :: np_local + integer :: i + + ! first getting the run name form the command line + ! (it's local, not global run_name) + ! also getting the parameter "split" which governs the process splitting: + ! split="split" means that hydro, statistics and particles are assigned three + ! separate process groups (they differ by the char*5 parameter "task"). + ! split="never" (default if the parameter is missing) means that all + ! processes do all tasks. (does not work for the particles at this point) + call openmpi_get_command_line + + + ! initializing MPI environment + call MPI_INIT(mpi_err) + call MPI_Comm_size(MPI_COMM_WORLD,numprocs_world,mpi_err) + call MPI_Comm_rank(MPI_COMM_WORLD,myid_world,mpi_err) + +!-------------------------------------------------------------------------------- +! Looking at the command line parameter called "split". If it equals "split" +! then we define task_split=.true. If not, task_split remains .false. (default) +!-------------------------------------------------------------------------------- + if (split == "split") task_split = .true. + +!-------------------------------------------------------------------------------- +! First check if we need to do any task splitting. If we don't (split="never") +! then we define task="hydro" and do a ficticious split with uniform color of +! all processors. +!-------------------------------------------------------------------------------- + if (.not. task_split) then +!!$ print *,'not splitting into task groups, all procs are "hydro"' + task = 'hydro' + color = 0 + myid = myid_world + goto 1000 + end if + +!-------------------------------------------------------------------------------- +! Definition of processor groups: hydro, stats, parts etc. for task splitting. +!-------------------------------------------------------------------------------- + + ! first finding out if there are any particles involved. + ! if there are no particles, then we split the processors in two parts: + ! hydro and stats. If there are some particles, we split the processors + ! in three parts: "hydro", "stats" and "parts". The variables that + ! determines which part the process belongs to is "task". + + ! first see, how many particles are there + if (myid_world.eq.0) then + ! opening the inupt file + open(99,file=run_name_local//'.in') + ! skipping the first 35 lines + do i = 1,35 + read(99,*) + end do + ! reading the number of particles + read(99,*) np_local + close(99) + end if + + ! broadcasting the number of particles to all processors + count = 1 + call MPI_BCAST(np_local,count,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) + + ! now splitting the processors in tasks: hydro, stats and parts + ! the curren logic is this: + ! - In case if there are no particles, the split between the hydro and + ! the stats part is 2/3 and 1/3. This way the total number of processors + ! needs to be 3*2^n + ! - In case with the particles in the flow, the split is 1/2, 1/4 and 1/4 + + ! first the case when we do not have particles + if (np_local.eq.0) then + + ! if the numprocs_total is divisible by 3, assign 2/3 of it to hydro + ! and the rest to stats + if (int(numprocs_world/3)*3 .eq. numprocs_world) then + numprocs_hydro = numprocs_world * 2/3 + numprocs_stats = numprocs_world - numprocs_hydro + numprocs_parts = 0 + else if (2**floor(log(real(numprocs_world))/log(2.d0)) .eq. numprocs_world) then + print*, 'numprocs_world is 2^n, allocating half for hydro: ',numprocs_world + numprocs_hydro = numprocs_world / 2 + numprocs_stats = numprocs_world - numprocs_hydro + numprocs_parts = 0 + else + ! if the # of processors N is not 2^n and not divisible by 3, then just take + ! the biggest 2^k < N and make these hydro, the rest - stat. + numprocs_hydro = 2**floor(log(real(numprocs_world))/log(2.d0)) + numprocs_stats = numprocs_world - numprocs_hydro + numprocs_parts = 0 + end if + + id_root_hydro = 0 + id_root_stats = numprocs_hydro + id_root_parts = 0 + + else + numprocs_hydro = numprocs_world / 2 + numprocs_stats = numprocs_world / 4 + numprocs_parts = numprocs_world / 4 + + id_root_hydro = 0 + id_root_stats = numprocs_hydro + id_root_parts = numprocs_hydro + numprocs_stats + + end if + + ! splitting the communicator into several parts + ! 1. hydro + ! 2. stats + ! 3. parts + + if (myid_world.lt.numprocs_hydro) then + task = 'hydro' + color = 0 + myid = myid_world + elseif (myid_world.ge.numprocs_hydro .and. myid_world .lt. numprocs_hydro+numprocs_stats) then + task = 'stats' + color = 1 + myid = myid_world - numprocs_hydro + else + task = 'parts' + color = 2 + myid = myid_world - numprocs_hydro - numprocs_stats + end if + +!-------------------------------------------------------------------------------- +! The actual task splitting happens here +!-------------------------------------------------------------------------------- +1000 continue + call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,myid,MPI_COMM_TASK,mpi_err) + call MPI_COMM_SIZE(MPI_COMM_TASK,numprocs,mpi_err) + call MPI_COMM_RANK(MPI_COMM_TASK,myid,mpi_err) + + + ! each task will have its master process + master = 0 + iammaster = .false. + if (myid.eq.master) iammaster=.true. + + +!!$ ! The following is put on hold because it looks like a crazy idea + +!!$ ! now creating separate exclusive communicator for the master nodes only +!!$ ! the name of the new communicator is MPI_COMM_ROOTS +!!$ ! if we want quickly broadcast something, then we can use two BCAST calls +!!$ color = 1 +!!$ if (iammaster) color = 0 +!!$ call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,myid_world,MPI_COMM_ROOTS,mpi_err) + + + + return + end subroutine m_openmpi_init + +!================================================================================ + + subroutine m_openmpi_exit + + call MPI_COMM_FREE(MPI_COMM_TASK,mpi_err) + call MPI_FINALIZE(mpi_err) + + return + end subroutine m_openmpi_exit + + +!================================================================================ + + subroutine openmpi_get_command_line + implicit none + + character*80 :: tmp_str + integer :: iargc + + ! reading the run_name from the command line + if(iargc().eq.0) then + call getarg(0,tmp_str) + print*, 'Format: ',trim(tmp_str),' (run name) ["split"/"never"]' + stop + end if + call getarg(1,run_name_local) + if(len_trim(run_name_local).ne.10) then + print *, 'Run name: "',run_name_local,'"' + print *, ' "1234567890"' + print *, 'Length of run name is less than 10, sorry.' + stop + end if + + ! getting the split parameter, if it's there + if(iargc().eq.2) call getarg(2,split) + + + end subroutine openmpi_get_command_line + +!================================================================================ + +end module m_openmpi diff --git a/m_parameters.f90 b/m_parameters.f90 new file mode 100644 index 0000000..ea88ace --- /dev/null +++ b/m_parameters.f90 @@ -0,0 +1,515 @@ +!================================================================================ +! M_PARAMETERS - module for all parameters in the calculation: +! such as array dimensions, reynolds numbers, switches/flags etc. +! +! Time-stamp: <2009-08-19 11:50:11 (chumakov)> +! Time-stamp: <2008-11-20 17:27:59 MST (vladimirova)> +!================================================================================ + +module m_parameters + + use m_openmpi + use m_io + implicit none + + ! --- problem related + + character*10 :: run_name + + ! --- input filep arameters + integer :: nx,ny,nz, nz_all ! Dimensions of the problem + integer :: nxyz, nxyz_all + integer :: n_scalars ! # of scalars + real*8 :: time ! time of simulation + real*8 :: dx, dy, dz + integer :: kmax + + + integer :: ITIME, ITMIN, ITMAX, IPRINT1, IPRINT2, IWRITE4 + + real*8 :: TMAX, TRESCALE, TSCALAR, RE, nu, dt + + ! now many times to rescale teh velocities + integer :: NRESCALE + + integer :: flow_type + + logical :: variable_dt + + integer :: isp_type, ir_exp, force_type + + real*8 :: peak_wavenum + + real*8 :: famp + + integer :: kfmax ! Maximum wavenumber for forcing (integer) + + real*8 :: courant + + + integer :: dealias + + integer :: det_rand + real*8 :: RN1, RN2, RN3 + + ! particle-related + + ! indicator that says which particle tracking scheme to use: + ! 0 = trilinear + ! 1 = spectral + ! 2 = tricubic + ! trilinear by default + integer :: particles_tracking_scheme = 0 + real*8 :: starttime_particles + + ! sometimes we want to advect particles by locally averaged field + ! the following variables address that concern + real*8 :: particles_filter_size + + ! number of particles assigned to the processor + ! and the total number of particles + integer(kind=MPI_INTEGER_KIND) :: np, np1, nptot + + ! If using Large Eddy Simulation (LES), the LES model ID is here + integer :: les_model + + integer, allocatable :: scalar_type(:) + real*8, allocatable :: pe(:), sc(:), ir_exp_sc(:), peak_wavenum_sc(:), reac_sc(:) + + + ! constants + real*8 :: zip=0.0d0, half=0.5d0 + real*8 :: one=1.0d0,two=2.0d0,three=3.d0,four=4.d0,five=5.d0, six=6.d0 + + + integer :: last_dump + + ! --- supporting stuff + logical :: there + logical :: fos, fov + integer :: ierr + real*8 :: PI, TWO_PI + + logical :: int_scalars, int_particles + + + ! --- number of LES variables in the arrays (initialized to zero) + integer :: n_les = 0 + + ! benchmarking tools + logical :: benchmarking=.false. + integer (kind=8) :: i81, i82, bm(12) + +!================================================================================ +contains +!================================================================================ + + subroutine m_parameters_init + + implicit none + + call get_run_name + + ! constants + PI = four * atan(one) + TWO_PI = two * PI + + ! switches + int_scalars = .false. + + call read_input_file + + ! maximum resolved wavenumber + if (dealias.eq.0) then + kmax = nx/3 + elseif (dealias.eq.1) then + kmax = floor(real(nx,8) / three * sqrt(two)) + else + write(out,*) "*** M_PARAMETERS_INIT: wrong dealias flag: ",dealias + call flush(out) + call my_exit(-1) + end if + + + write(out,*) "kmax = ",kmax + call flush(out) + + end subroutine m_parameters_init + +!================================================================================ + + subroutine get_run_name + implicit none + + character*80 :: tmp_str + integer :: iargc + + ! reading the run_name from the command line + if(iargc().eq.0) then + call getarg(0,tmp_str) + write(out,*) 'Format: ',trim(tmp_str),' ' + write(*,*) 'Format: ',trim(tmp_str),' ' + call flush(out) + call MPI_FINALIZE(ierr) + stop + end if + call getarg(1,run_name) + if(len_trim(run_name).ne.10) then + write(out,*) 'Run name: "',run_name,'"' + write(out,*) ' "1234567890"' + write(out,*) 'Length of run name is less than 10, sorry.' + call MPI_FINALIZE(ierr) + stop + end if + write(out,*) 'Run name: "',run_name,'"' + call flush(out) + + end subroutine get_run_name + + +!================================================================================ + + subroutine read_input_file + + implicit none + + logical :: there + integer :: n + integer*4 :: passed, passed_all + character*80 :: str_tmp + + ! making sure the input file is there + inquire(file=run_name//'.in', exist=there) + if(.not.there) then + write(out,*) '*** cannot find the input file' + call flush(out) + call my_exit(-1) + end if + + ! now the variable "passed" will show if the parameters make sense + passed = 1 + + + ! ------------------------------------------------- + ! reading parameters from the input file + ! and checking them for consistency + ! ------------------------------------------------- + open(in,file=run_name//'.in',form='formatted') + read(in,*) + read(in,*) + read(in,*) + + read(in,*,ERR=9000) nx,ny,nz_all + read(in,*) + + + nz = nz_all/numprocs + if (nz*numprocs.ne.nz_all) then + write(out,*) '*** wrong nz_all:', nz_all, & + '*** should be divisible by numprocs:',numprocs + call flush(out) + passed = 0 + end if + write(out,'(70(''=''))') + write(out,"('NX,NY,NZ_ALL', 3i4)") nx,ny,nz_all + write(out,"('NX,NY,NZ ', 3i4)") nx,ny,nz + call flush(out) + + dx = 2.0d0 * PI / dble(nx) + dy = 2.0d0 * PI / dble(ny) + dz = 2.0d0 * PI / dble(nz_all) + + ! ------------------------------------------------------------- + + read(in,*,ERR=9000,END=9000) ITMIN + write(out,*) 'ITMIN = ',ITMIN + last_dump = ITMIN + + read(in,*,ERR=9000,END=9000) ITMAX + write(out,*) 'ITMAX = ',ITMAX + + read(in,*,ERR=9000,END=9000) IPRINT1 + write(out,*) 'IPRINT1= ',IPRINT1 + + read(in,*,ERR=9000,END=9000) IPRINT2 + write(out,*) 'IPRINT2= ',IPRINT2 + + read(in,*,ERR=9000,END=9000) IWRITE4 + write(out,*) 'IWRITE4= ',IWRITE4 + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) TMAX + write(out,*) 'TMAX =',TMAX + + read(in,*,ERR=8000,END=9000) TRESCALE, NRESCALE +100 write(out,*) 'TRESCALE, NRESCALE =',TRESCALE, NRESCALE + + read(in,*,ERR=9000,END=9000) TSCALAR + write(out,*) 'TSCALAR =',TSCALAR + read(in,*) + write(out,"(70('-'))") + call flush(out) + +! if(TSCALAR.le.TRESCALE) then +! TSCALAR = TRESCALE +! write(out,*) '*** RESET: TSCALAR = ',TSCALAR +! end if + + ! ------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) flow_type + write(out,*) 'flow_type ', flow_type + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) RE + write(out,*) 'RE = ',RE + + nu = 1.0d0/RE + + read(in,*,ERR=9000,END=9000) DT + write(out,*) 'DT = ',DT + if (dt.lt.0.0d0) then + variable_dt = .false. + dt = -dt + else + variable_dt = .true. + end if + + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) isp_type + write(out,*) 'isp_type= ', isp_type + + read(in,*,ERR=9000,END=9000) ir_exp + write(out,*) 'ir_exp = ', ir_exp + + read(in,*,ERR=9000,END=9000) peak_wavenum + write(out,*) 'peak_wavenum = ',peak_wavenum + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) force_type + write(out,*) 'force_type', force_type + + read(in,*,ERR=9000,END=9000) kfmax + write(out,*) 'kfmax = ',kfmax + + read(in,*,ERR=9000,END=9000) FAMP + write(out,*) 'FAMP = ',FAMP + + read(in,*) + write(out,"(70('-'))") + call flush(out) + +!!$ c------------------------------------------------------------ +!!$ +!!$ read(in,*,ERR=9000,END=9000) IRESET +!!$ write(out,*) 'IRESET= ',IRESET +!!$ +!!$ read(in,*,ERR=9000,END=9000) INEWSC +!!$ write(out,*) 'INEWSC= ',INEWSC +!!$ read(in,*) +!!$ +!!$ c------------------------------------------------------------ + + read(in,*,ERR=9000,END=9000) dealias + write(out,*) 'dealias = ',dealias + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------- + + read(in,*,ERR=9000,END=9000) det_rand + write(out,*) 'det_rand =',det_rand + + read(in,*,ERR=9000,END=9000) RN1 + write(out,*) 'RN1 =',RN1 + + read(in,*,ERR=9000,END=9000) RN2 + write(out,*) 'RN2 =',RN2 + + read(in,*,ERR=9000,END=9000) RN3 + write(out,*) 'RN3 =',RN3 + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------- + + read(in,*,ERR=9000,END=9000) nptot +! DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG + if (.not.task_split .and. nptot > 0) then + write(out,*) "tasks are not split, making nptot=0" + nptot = 0 + end if +! DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG + + write(out,*) 'nptot =',nptot + + + read(in,*,ERR=9000,END=9000) particles_tracking_scheme + write(out,*) 'particles_tracking_scheme', particles_tracking_scheme + + select case (particles_tracking_scheme) + case (0) + write(out,*) '--- Trilinear tracking' + case (1) + write(out,*) '--- CINT (cubic interpolation on integer nodes)' + case (2) + write(out,*) '--- Spectral tracking (CAUTION: SLOW!)' + case default + write(out,*) 'don''t recognize particle tracking:', & + particles_tracking_scheme + write(out,*) 'reset to zero' + particles_tracking_scheme = 0 + end select + call flush(out) + + +! DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG + if (particles_tracking_scheme .gt. 1) stop 'Cannot do this particle tracking' +! DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG DEBUG + + + + read(in,*,ERR=9000,END=9000) starttime_particles + write(out,*) 'starttime_particles: ',starttime_particles + + read(in,*,ERR=9000,END=9000) particles_filter_size + write(out,*) 'particles_filter_size:',particles_filter_size + + if (particles_filter_size .gt. zip .and. particles_filter_size .lt. three*dx) then + write(out,*) "particles_filter_size is too small (less than 3*dx)" + write(out,*) particles_filter_size, three*dx + call flush(out) + call my_exit(-1) + end if + + read(in,*) + + + ! ------------------------------------------------------------- + + read(in,*,ERR=9000,END=9000) les_model + write(out,*) 'les_model =',les_model + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! making sure that if the LES mode is on, the dealiasing is 3/2-rule + if (les_model .gt. 0 .and. dealias .ne. 0) then + dealias = 0 + write(out,*) "*** LES mode, changing dealias to 0." + call flush(out) + end if + + ! ------------------------------------------------------------- + + read(in,*,ERR=9000,END=9000) n_scalars + write(out,*) '# of scalars:', n_scalars + read(in,*) + write(out,"(70('-'))") + call flush(out) + + ! ------------------------------------------------------------ + + ! if there are scalars, then read them one by one + if (n_scalars>0) then + read(in,'(A)',ERR=9000,END=9000) str_tmp + write(out,*) str_tmp + call flush(out) + + ! reading parameters of each scalar + allocate(scalar_type(n_scalars), pe(n_scalars), sc(n_scalars), & + ir_exp_sc(n_scalars), peak_wavenum_sc(n_scalars), & + reac_sc(n_scalars), stat=ierr) + if (ierr.ne.0) passed = 0 + + do n = 1,n_scalars + read(in,*,ERR=9000,END=9000) scalar_type(n), sc(n), ir_exp_sc(n), & + peak_wavenum_sc(n), reac_sc(n) + write(out,'(9x,i4,1x,4(f8.3,1x))') scalar_type(n), sc(n), ir_exp_sc(n), & + peak_wavenum_sc(n), reac_sc(n) + call flush(out) + + PE(n) = nu/SC(n) ! INVERSE Peclet number + + end do + end if + + ! ------------------------------------------------------------- + + ! closing the input file + close(in) + write(out,'(70(''=''))') + call flush(out) + + ! defining the rest of the parameters + + nxyz = nx * ny * nz + nxyz_all = nx * ny * nz_all + + ! ------------------------------------------------------------ + + +!-------------------------------------------------------------------------------- +! Checking if the task splitting conflicts with particle advection. Currently +! we canot have split=never and have particles. This is to be resolved later, +! now my head is spinning already. +!-------------------------------------------------------------------------------- + if (.not.task_split .and. nptot.gt.0) then + write(out,*) "*** READ_INPUT_FILE: Cannot have .not.task_split and nptot > 0. Stopping" + call flush(out) + passed = 0 + end if +!-------------------------------------------------------------------------------- + + + count = 1 + call MPI_REDUCE(passed,passed_all,count,MPI_INTEGER4,MPI_MIN,0,MPI_COMM_WORLD,mpi_err) + count = 1 + call MPI_BCAST(passed_all,count,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) + + if (passed.lt.one) then + write(out,*) "not passed the check, stopping" + call flush(out) + stop + end if + + return + +!-------------------------------------------------------------------------------- +! ERROR PROCESSING +!-------------------------------------------------------------------------------- + +8000 continue + NRESCALE = 0 + if (TRESCALE.gt.zip) NRESCALE = 1 + write(out,*) "*** NRESCALE IS AUTOMATICALLY ASSIGNED to be ONE" + call flush(out) + goto 100 + +9000 continue + write(out,*)'An error was encountered while reading input file' + call flush(out) + stop + end subroutine read_input_file + +!================================================================================ +end module m_parameters diff --git a/m_particles.f90 b/m_particles.f90 new file mode 100644 index 0000000..9d366a6 --- /dev/null +++ b/m_particles.f90 @@ -0,0 +1,1512 @@ +!================================================================================ +module m_particles +!================================================================================ +! Incompressible pseudo-spectral code with scalars +! +! The module contains subroutines for Largangian particle tracking. +! +! +!================================================================================ +! VARIABLES +!================================================================================ + + use m_parameters + use m_io + implicit none + + ! logical variable that indicates if we integrate the particles +! logical :: int_particles + + ! when to release the particles + real*8 :: time_p + + ! array which contains the particles' positions in the grid units + real*8, allocatable :: xyzp(:,:) + + ! array with second-layer velocities for particles + real*8, allocatable :: uvwp(:,:) + + ! array with particles' tags (1 to nptot) + integer*4, allocatable :: ipart(:) + + ! array with particles' addresses (which processors hold the particle) + integer*4, allocatable :: myid_part(:), itmp_part(:) + + ! min and max z-coordinate for a slab + real*8 :: zmin,zmax + + ! temp arrays for particle interpolation + real*8, allocatable :: wrk1p(:,:), wrk2p(:,:), wrk3p(:,:) + + ! tmp arrays for CINT interpolation procedure (see particles_move_cint.f90) +! real*8, allocatable :: + + ! needed to avoid deadlock in send/receive particles + real*8, allocatable :: xyzp1(:,:), uvwp1(:,:) + integer*4, allocatable :: ipart1(:) + + ! number of particles to be sent/received to/from neighbours when moving + ! the particles + integer*4 :: np_send_u, np_send_d, np_get_u, np_get_d + + ! the last iteration at which the particles were written out + integer :: particles_last_dump = -1 + +!================================================================================ +!================================================================================ + +contains + +!================================================================================ +! SUBROUTINES +!================================================================================ + + subroutine particles_allocate + + use m_io + implicit none + + write(out,*) 'Particle allocation' + call flush(out) + + ! allocate the arrays + if (.not.allocated(xyzp)) then + allocate(xyzp(3,nptot),uvwp(3,nptot),ipart(nptot),itmp_part(nptot),& + myid_part(nptot),& + xyzp1(3,nptot),uvwp1(3,nptot),ipart1(nptot),stat=ierr) + if (ierr.ne.0) stop 'particle allocation' + else + write(out,*) 'arrays xyzp etc are already allocated.' + call flush(out) + end if + + + ! allocating temp arrays for CINT interpolation + if (particles_tracking_scheme.eq.2) then + write(out,*) 'Allocating temp arrays for CINT interpolation' + call flush(out) + if (.not.allocated(wrk1p)) then + allocate(wrk1p(nx,ny), wrk2p(nx,ny), wrk3p(nx,ny),stat=ierr) + wrk1p = zip; wrk2p = zip; wrk3p = zip; + if (ierr.ne.0) stop 'allocation of particle temp arrays' + else + write(out,*) 'arrays for CINT are already allocated.' + call flush(out) + end if + end if + + return + end subroutine particles_allocate + +!================================================================================ +!================================================================================ +!================================================================================ + + subroutine particles_deallocate + implicit none + + write(out,*) 'Particle deallocation.' + call flush(out) + + ! allocate the arrays + if (allocated(xyzp)) deallocate(xyzp,uvwp,ipart,itmp_part,myid_part) + + if (allocated(wrk1p)) deallocate(wrk1p,wrk2p,wrk3p,xyzp1,uvwp1,ipart1) + + return + end subroutine particles_deallocate + + +!================================================================================ +!================================================================================ +!================================================================================ +! PARTICLES_GET_MYID - fills the array myid_part, which contains the IDs of +! the processes that house the particles. +!================================================================================ + subroutine particles_get_myid + + + implicit none + + integer :: n + + ! filling up the array which contains id's of processes that are + ! responsible for each particle + + itmp_part = 0 + myid_part = 0 + + if (np.gt.0) then + do n = 1,np + itmp_part( ipart(n) ) = myid + end do + end if + + call MPI_REDUCE(itmp_part,myid_part,nptot,MPI_INTEGER4,MPI_SUM,master,MPI_COMM_TASK,ierr) + + call MPI_BCAST(myid_part,nptot,MPI_INTEGER4,master,MPI_COMM_TASK,ierr) + + return + end subroutine particles_get_myid + +!================================================================================ +!================================================================================ +!================================================================================ +! PARTICLES_INIT - initializes the particles +!================================================================================ + subroutine particles_init +!-------------------------------------------------------------------------------- +! particle initialization: +! - aray allocation +! - reading coordinates of particles from the file .pt +! - shifing the particles so hey are in [0:2*pi) +! - distributing the particles among CPUs +!-------------------------------------------------------------------------------- + + use m_filter_xfftw + + implicit none + + logical :: init_start = .false., init_internally = .false. + integer :: i,j,k,npthird,n + real*8 :: sctmp + +!-------------------------------------------------------------------------------- + + ! first, some foolproofing + int_particles = .false. + + ! if the total # of particles is zero, return without initialization + if (nptot.eq.0) then + write(out,*) ' nptot = 0, no particles initialized.' + call flush(out) + return + end if + +!-------------------------------------------------------------------------------- +! choose which way to initialize particles: +! 1. read from file .pt (manually given coordinates) +! 2. generate uniformly spaced particles in the computational domain +! (in this case the number of particles is taken to be nptot=2^n, where +! n is such that nptot is close to what is specified in the input file) +!-------------------------------------------------------------------------------- + + + ! if the file pt. is there, then read particles from it and return. + ! whatever is specified in the pt., supercedes anything else. + + inquire(file='pt.'//file_ext,exist=there) + if (there) then + write(out,*) 'Detected file pt.'//file_ext + write(out,*) 'Particles will be read from the file.' + call particles_restart_read_binary + return + end if + + ! if the restart file is not there, we assume that it's a + ! brand new particle simulation so we read the particle + ! coordinates from the "run_name".pt file + ! --------- OR ---------- + ! define particles as uiformly distributed over the domain + + + ! check if the .pt is in the directory + inquire(file=run_name//'.pt',exist=there) + if (there) then + write(out,*) 'Reading particles from the file '//run_name//'.pt' + call flush(out) + init_start = .true. + else + ! if not reading from the file, redefine nptot + init_internally = .true. + npthird = int(dble(nptot)**(1.d0/3.d0)) + if (nptot-npthird**3.ge.(npthird+1)**3-nptot) npthird = npthird + 1 + nptot = npthird**3 + nptot = min(nptot,2**30) + write(out,*) 'Redefined nptot to be a perfect cube:',nptot + if (nptot.eq.2**30) write(out,*) "REACHED MAXIMUM: 2**30" + call flush(out) + end if + + + write(out,*) 'Initializing',nptot,' particles' + call flush(out) + + call particles_allocate + + + if (myid.eq.0) then + ! read the whole array of particles + if (init_start) then + open(99,file=run_name//'.pt') + read(99,*,ERR=9000,END=9000) ((xyzp(i,j),i=1,3),j=1,nptot) + close(99) + end if + + ! ... or define it manually + + sctmp = two*PI / real(npthird,8) + + if (init_internally) then + n = 0 + do k = 1,npthird + do j = 1,npthird + do i = 1,npthird + n = n + 1 + xyzp(1,n) = (dble(i-1)+half) * sctmp + xyzp(2,n) = (dble(j-1)+half) * sctmp + xyzp(3,n) = (dble(k-1)+half) * sctmp + end do + end do + end do + end if + + end if + + + ! Broadcast the array of particles + call MPI_BCAST(xyzp,nptot*3,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + + + ! definition of particles' identifiers + do i = 1,nptot + ipart(i) = i + end do + +!!$ write(out,*) 'Particles read in:' +!!$ write(out,'(3f20.10)') ((xyzp(i,j),i=1,3),j=1,nptot) +!!$ call flush(out) + + ! REARRANGING THE PARTICLES + + ! makign sure the xyz are in [0,2*pi) + do j=1,nptot + do i = 1,3 + if (xyzp(i,j) .ge. 2.0d0*PI .or. xyzp(i,j) .lt. 0.0d0) then + xyzp(i,j) = xyzp(i,j) - 2.0d0*PI * dble(floor(xyzp(i,j)/(2.0d0*PI))) + end if + end do + end do + +!!$ write(out,*) 'Particles normalized:',nptot +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,nptot) + + ! removing particles that do not correspond to this slab + np = nptot + j = 1 + zmin = dble(myid*nz) * 2.0d0*PI / dble(nz_all) + zmax = dble((myid+1)*nz) * 2.0d0*PI / dble(nz_all) + + do while (j.le.np) + if (xyzp(3,j).ge.zmin .and. xyzp(3,j).lt.zmax) then + j = j + 1 + else + xyzp(:,j) = xyzp(:,np) + ipart(j) = ipart(np) + np = np-1 + end if + end do + +!!$ write(out,*) 'Particles left in:',np +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,np) + + ! Recalculating the particles' coordinates in grid cells + do j = 1,np + xyzp(1,j) = xyzp(1,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 + xyzp(2,j) = xyzp(2,j) / (2.0d0 * PI / dble(ny)) + 1.0d0 + xyzp(3,j) = xyzp(3,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 - dble(myid*nz) + end do + write(out,*) 'Particles left in, rescaled:',np +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,np) + + + ! initializing uvwp with -999.00 + uvwp = -999.0d0 + +!!$ ! making a subdirectory "particles" +!!$ if (iammaster) call system('mkdir -p particles') + + ! in case if the particles are advected by locally averaged field + ! (particles_filter_size > 0), define the filter + if (particles_filter_size > 0.d0) call filter_xfftw_init + + return +9000 write(out,*) '*** PARTICLES_INIT: ERROR in reading file .pt !!!' + stop + end subroutine particles_init + +!=========================================================================== +!=========================================================================== +! Subroutine that writes out the particles coordinates in a file +! during the restart write +!=========================================================================== + subroutine particles_restart_write + + + implicit none + + integer(kind=MPI_INTEGER_KIND) :: id, count, my_status(MPI_STATUS_SIZE) + integer*4 :: np_rec + integer :: np_cur, ntmp + + + if (.not.int_particles) return + + write(out,*) 'writing the particle restart file' + call flush(out) + + ! ------------------------------------------------------------------------------ + ! the slave nodes send their particles' IDs and coordinates to the master node + ! the master node assembles the particles IDs and coordinates in one array and + ! writes them out + ! ------------------------------------------------------------------------------ + if (myid.ne.0) then + + ! First send the number of particles that the process holds to the master process + np_rec = np + call MPI_SEND(np_rec,1,MPI_INTEGER4,0,3*myid,MPI_COMM_TASK,mpi_err) + +! write(out,*) 'Sent np=',np_rec,' to master',mpi_err +! call flush(out) + + ! if the number of particles is positive, send their IDs and coordinates + if (np.gt.0) then + count = np + call MPI_SEND(ipart(1),count,MPI_INTEGER4,0,3*myid+1,MPI_COMM_TASK,mpi_err) + +! write(out,*) 'Sent ipart to master',mpi_err +! call flush(out) + + count = 3*np + call MPI_SEND(xyzp(1,1),count,MPI_REAL8,0,3*myid+2,MPI_COMM_TASK,mpi_err) + +! write(out,*) 'Sent xyzp to master',mpi_err +! call flush(out) + + end if + + else + + np_cur = np+1 + do id = 1,numprocs-1 + ! master node receives the number of particles from slave node + call MPI_RECV(np_rec,1,MPI_INTEGER4,id,3*id,MPI_COMM_TASK,my_status,mpi_err) + +! write(out,*) 'Received ',np_rec,' from ',id,':',mpi_err +! call flush(out) + + ! if there are any particles to receive, receive the IDs and coordinates + if (np_rec.gt.0) then + count = np_rec + call MPI_RECV(ipart(np_cur),count,MPI_INTEGER4,id,3*id+1,MPI_COMM_TASK,my_status,mpi_err) + +! write(out,*) 'Received ipart from ',id,':',mpi_err +! call flush(out) + + count = 3 * np_rec + call MPI_RECV(xyzp(1,np_cur),count,MPI_REAL8,id,3*id+2,MPI_COMM_TASK,my_status,mpi_err) + +! write(out,*) 'Received xyzp from ',id,':',mpi_err +! call flush(out) + + ! since the xyzp contains particle coordinates in terms of the cells, the third + ! coordinate should be augmented by id*nz. this is done so later we can just + ! multiply the third coordinate by dz to get the real particle coordinate + do ntmp = np_cur,np_cur+np_rec + xyzp(3,ntmp) = xyzp(3,ntmp) + dble(nz*id) + end do + end if + np_cur = np_cur + np_rec + + end do + end if + + ! ------------------------------------------------------------------------------ + ! Now the master node opens the particle restart file .pt. + ! and writes the particles with their IDs in it. + ! ------------------------------------------------------------------------------ + + if (myid.eq.0) then + open(89,file=run_name//'.pt.'//file_ext) + do ntmp = 1,nptot + write(89,'(i6,x,10d16.8)') ipart(ntmp),& + (xyzp(1,ntmp)-1.d0)*dx,(xyzp(2,ntmp)-1.d0)*dy,(xyzp(3,ntmp)-1.d0)*dz + end do + close(89,status='keep') + write(out,*) 'particle restart file written.' + call flush(out) + end if + + + return + end subroutine particles_restart_write + + +!=========================================================================== +!=========================================================================== +! Subroutine that reads in the particles from the particle restart file +!=========================================================================== + subroutine particles_restart_read + + + implicit none + + logical :: there + character*80 :: fname + integer :: n,i,j + + + if (nptot.eq.0) return + + ! allocate the arrays + if (.not.allocated(xyzp)) then + allocate(xyzp(3,nptot),uvwp(3,nptot),ipart(nptot),itmp_part(nptot),& + myid_part(nptot),stat=ierr) + if (ierr.ne.0) stop 'particle allocation' + else + write(out,*) 'PARTICLES_RESTART_READ: xyzp allocated already!' + call flush(out) + end if + + fname = run_name//'.pt.'//file_ext + write(out,*) 'Reading the particles from file '//fname + call flush(out) + +!------------------------------------------------------------------------- +! Reading and broadcasting the particles' IDs and coordinates +!------------------------------------------------------------------------- + + inquire(file=fname,exist=there) + if(.not.there) then + write(out,*) 'could not find the particle restart file ',fname + write(out,*) 'exiting.' + call flush(out) + call my_exit(-1) + end if + + if (myid.eq.0) then + open(81,file=fname) + do n = 1,nptot + read(81,*,ERR=9000,END=9000) ipart(n),xyzp(1:3,n) + end do + close(81) + end if + + call MPI_BCAST(ipart,nptot,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(xyzp,nptot*3,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + + write(out,*) 'Particles normalized:',nptot + do j = 1,nptot + write(out,'(i5,3f20.10)') ipart(j),(xyzp(i,j),i=1,3) + end do + +!------------------------------------------------------------------------- +! removing particles that do not correspond to this slab +!------------------------------------------------------------------------- + + write(out,*) 'removing particles that do not correspond to this slab' + call flush(out) + + np = nptot + j = 1 + zmin = dble(myid*nz) * 2.0d0*PI / dble(nz_all) + zmax = dble((myid+1)*nz) * 2.0d0*PI / dble(nz_all) + + do while (j.le.np) + if (xyzp(3,j).ge.zmin .and. xyzp(3,j).lt.zmax) then + j = j + 1 + else + xyzp(:,j) = xyzp(:,np) + ipart(j) = ipart(np) + np = np-1 + end if + end do + + write(out,*) 'Particles left in:',np + write(out,*) 'Particles normalized:',nptot + do j = 1,nptot + write(out,'(i5,3f20.10)') ipart(j),(xyzp(i,j),i=1,3) + end do + + ! Recalculating the particles' coordinates in grid cells + do j = 1,np + xyzp(1,j) = xyzp(1,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 + xyzp(2,j) = xyzp(2,j) / (2.0d0 * PI / dble(ny)) + 1.0d0 + xyzp(3,j) = xyzp(3,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 - dble(myid*nz) + end do + write(out,*) 'Particles left in, rescaled:',np + write(out,*) 'Particles normalized:',nptot + do j = 1,nptot + write(out,'(i5,3f20.10)') ipart(j),(xyzp(i,j),i=1,3) + end do + + + ! initializing uvwp with -999.00 + uvwp = -999.0d0 + + return +9000 write(out,*) 'Error reading particle restart file ',fname + stop + end subroutine particles_restart_read +!================================================================================ +!================================================================================ +!================================================================================ +! Subroutine that writes out the particles coordinates in a BINARY restart file +!================================================================================ + subroutine particles_restart_write_binary + + + implicit none + + integer(kind=MPI_INTEGER_KIND) :: id, count, my_status(MPI_STATUS_SIZE) + integer*4 :: np_rec + integer :: np_cur, ntmp + + ! if the last iteration at which the particles were written out is the + ! current iteration, then skip the writing + if (particles_last_dump .eq. itime) return + + ! otherwise proceed and redefine the particles_last_dump + particles_last_dump = itime + +!!$ write(out,*) 'writing the BINARY particle restart file' +!!$ call flush(out) + + ! ------------------------------------------------------------------------------ + ! the slave nodes send their particles' IDs and coordinates to the master node + ! the master node assembles the particles IDs and coordinates in one array and + ! writes them out + ! ------------------------------------------------------------------------------ + if (myid.ne.0) then + + ! First send the number of particles that the process holds to the master process + np_rec = np + call MPI_SEND(np_rec,1,MPI_INTEGER4,0,3*myid,MPI_COMM_TASK,mpi_err) + + ! if the number of particles is positive, send their IDs and coordinates + if (np.gt.0) then + count = np + call MPI_SEND(ipart(1),count,MPI_INTEGER4,0,3*myid+1,MPI_COMM_TASK,mpi_err) + + count = 3*np + call MPI_SEND(xyzp(1,1),count,MPI_REAL8,0,3*myid+2,MPI_COMM_TASK,mpi_err) + + end if + + else + + np_cur = np+1 + do id = 1,numprocs-1 + ! master node receives the number of particles from slave node + call MPI_RECV(np_rec,1,MPI_INTEGER4,id,3*id,MPI_COMM_TASK,my_status,mpi_err) + + ! if there are any particles to receive, receive the IDs and coordinates + if (np_rec.gt.0) then + count = np_rec + call MPI_RECV(ipart(np_cur),count,MPI_INTEGER4,id,3*id+1,MPI_COMM_TASK,my_status,mpi_err) + + count = 3 * np_rec + call MPI_RECV(xyzp(1,np_cur),count,MPI_REAL8,id,3*id+2,MPI_COMM_TASK,my_status,mpi_err) + + ! since the xyzp contains particle coordinates in terms of the cells, the third + ! coordinate should be augmented by id*nz. this is done so later we can just + ! multiply the third coordinate by dz to get the real particle coordinate + do ntmp = np_cur,np_cur+np_rec + xyzp(3,ntmp) = xyzp(3,ntmp) + dble(nz*id) + end do + end if + np_cur = np_cur + np_rec + + end do + end if + + ! ------------------------------------------------------------------------------ + ! Now the master node opens the particle BINARY file pt. + ! and writes the particles with their IDs in it. + ! ------------------------------------------------------------------------------ + + if (myid.eq.0) then +!! open(89,file='pt.'//file_ext,form='binary') + open(89,file='pt.'//file_ext,form='unformatted',access='stream') + write(89) nptot + do ntmp = 1,nptot + write(89) ipart(ntmp),& + (xyzp(1,ntmp)-1.d0)*dx,(xyzp(2,ntmp)-1.d0)*dy,(xyzp(3,ntmp)-1.d0)*dz + end do + ! writing time stamp in the particle output file + write(89) TIME + + close(89,status='keep') + write(out,'("particle BINARY file written:",i7,e15.6)') itime, time + call flush(out) + end if + + + return + end subroutine particles_restart_write_binary +!================================================================================ + + +!=========================================================================== +! Subroutine that reads in the particles from the particle restart file +!=========================================================================== + subroutine particles_restart_read_binary + + implicit none + + integer(kind=MPI_INTEGER_KIND) :: nptot1 + + logical :: there + character*80 :: fname + integer :: n,i,j + + + fname = 'pt.'//file_ext + write(out,*) 'Reading the particles from binary file '//fname + call flush(out) + +!------------------------------------------------------------------------- +! Reading and broadcasting the particles' IDs and coordinates +!------------------------------------------------------------------------- + +! Checking that the number of particles in the binary file is correct + if (myid.eq.0) then + open(81,file=fname,form='unformatted',access='stream') + read(81) nptot + end if + call MPI_BCAST(nptot,1,MPI_INTEGER,0,MPI_COMM_TASK,mpi_err) + + write(out,*) 'nptot = ',nptot + call flush(out) + + ! allocating arrays + call particles_allocate + + + ! Readign and broadcasting particles + if (myid.eq.0) then + do n = 1,nptot + read(81,ERR=9000,END=9000) ipart(n),xyzp(1:3,n) + end do + close(81) + end if + + call MPI_BCAST(ipart,nptot,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(xyzp,nptot*3,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + + write(out,*) 'Particles normalized:',nptot +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,nptot) + +!------------------------------------------------------------------------- +! removing particles that do not correspond to this slab +!------------------------------------------------------------------------- + + write(out,*) 'removing particles that do not correspond to this slab' + call flush(out) + + np = nptot + j = 1 + zmin = dble(myid*nz) * 2.0d0*PI / dble(nz_all) + zmax = dble((myid+1)*nz) * 2.0d0*PI / dble(nz_all) + + do while (j.le.np) + if (xyzp(3,j).ge.zmin .and. xyzp(3,j).lt.zmax) then + j = j + 1 + else + xyzp(:,j) = xyzp(:,np) + ipart(j) = ipart(np) + np = np-1 + end if + end do + + write(out,*) 'Particles left in:',np +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,np) + + ! Recalculating the particles' coordinates in grid cells + do j = 1,np + xyzp(1,j) = xyzp(1,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 + xyzp(2,j) = xyzp(2,j) / (2.0d0 * PI / dble(ny)) + 1.0d0 + xyzp(3,j) = xyzp(3,j) / (2.0d0 * PI / dble(nx)) + 1.0d0 - dble(myid*nz) + end do +!!$ write(out,*) 'Particles left in, rescaled:',np +!!$ write(out,'(i5,3f20.10)') ((ipart(j),(xyzp(i,j),i=1,3)),j=1,np) + + + ! initializing uvwp with -999.00 + uvwp = -999.0d0 + + return +9000 write(out,*) 'Error reading particle restart file ',fname + stop + end subroutine particles_restart_read_binary + + +!================================================================================ +!================================================================================ +!================================================================================ + subroutine particles_move + use m_fields + use m_work + use x_fftw + use m_filter_xfftw + implicit none + integer :: m, n + + if (task.ne.'parts') return + + + ! if the particles are advected by locally averaged velocities + ! instead of fully resolved velocities, then we need to filter + ! (locally average) these velocities. The indicator of this case is + ! particles_filter_size > 0.d0 + ! in this case the velocities that are sent to the "parts" part of the code + ! are given in the Fourier space. So we need to + ! 1) filter them + ! 2) transform them back to real space + + locally_averaged_velocity: if (particles_filter_size .gt. 0.d0) then + ! filter each field and transform to real space + do n = 1,3 + call filter_xfftw_fields(n) + call xFFT3d_fields(-1,n) + end do + end if locally_averaged_velocity + + ! now shifting particles according to the interpolation scheme and advection scheme + select case (particles_tracking_scheme) + case (0) + call particles_interpolate_trilinear + case (1) + call particles_interpolate_cint + case default + stop 'wrong particles_tracking_scheme' + end select + + call particles_update_slabs + + return + end subroutine particles_move + + +!================================================================================ +! PARTICLE VELOCITY INTERPOLATION AND MOVING +! +! This is set up in the following way: +! +! The interpolation subroutines do the following: +! 1) find particles' velocities using some interpolation methof +! 2) move the particles according to the numerical scheme +! (Euler or Adams-Bashforth) +! 3) Calculate the number of particles that went out of the slab: +! np_send_d - # of particles that needs to be sent "down", to slab # myid-1 +! np_send_u - # of particles that needs to be sent "up", to slab # myid+1 +! +! Then the subroutine particles_update_slabs should be called, which +! 1) rearranges particles according to their destination (here, down, up) +! 2) inform the neighbor slabs about the number of particles to send +! 3) transfer particles between the slabs +! +! May the Force be with us. +!================================================================================ +!================================================================================ + subroutine particles_interpolate_trilinear + + use m_fields + use m_work + + implicit none + + integer :: i,j,k,i1,j1,k1,n + real*8 :: xp,yp,zp,up,vp,wp + real*8 :: c1,c2,c3,c4,c5,c6,c7,c8 + + ! note that we assume that fields1...3 contain REAL velocities (in X-space) + + ! to interpolate velocities of the particles that are on the upper z-edge of + ! the slice, we need the first layer of velocities from the neibour process. + ! This is done by sending them to the process with number (myid-1) and storing + ! in the first three slices (k=1,3) of wrk0 + + id_to = mod(myid-1+numprocs,numprocs) + id_from = mod(myid+1,numprocs) + + ! sending u + sendtag = 3 * myid + recvtag = 3 * id_from + + count = (nx+2)*ny + call MPI_IRECV( wrk(1,1,1,0), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,1), count, MPI_REAL8, id_to, sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + ! sending v + sendtag = 3 * myid + 1 + recvtag = 3 * id_from + 1 + + count = (nx+2)*ny + call MPI_IRECV( wrk(1,1,2,0), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,2), count, MPI_REAL8, id_to, sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + ! sending w + sendtag = 3 * myid + 2 + recvtag = 3 * id_from + 2 + + count = (nx+2)*ny + call MPI_IRECV( wrk(1,1,3,0), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,3), count, MPI_REAL8, id_to, sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + ! # of particles to be sent/received to/from left and right neibors + np_send_d = 0 + np_send_u = 0 + np_get_d = 0 + np_get_u = 0 + + + ! interpolating the velocities and moving + do n = 1,np + + ! getting the cell where the particle is at + i = floor(xyzp(1,n)) + j = floor(xyzp(2,n)) + k = floor(xyzp(3,n)) + + ! getting fractional coordinates of the particle + xp = xyzp(1,n) - dble(i) + yp = xyzp(2,n) - dble(j) + zp = xyzp(3,n) - dble(k) + + ! cpefficients for trilinear interpolation + c1 = (one-xp) * (one-yp) * (one-zp) + c2 = (xp) * (one-yp) * (one-zp) + c3 = (one-xp) * (yp) * (one-zp) + c4 = (xp) * (yp) * (one-zp) + c5 = (one-xp) * (one-yp) * (zp) + c6 = (xp) * (one-yp) * (zp) + c7 = (one-xp) * (yp) * (zp) + c8 = (xp) * (yp) * (zp) + + ! accounting for periodicity in x and y directions + if (i.eq.nx) then + i1 = 1 + else + i1 = i + 1 + end if + + if (j.eq.ny) then + j1 = 1 + else + j1 = j + 1 + end if + + ! interpolating velocities to get the velocity of the particle + + up = c1 * fields(i,j ,k,1) + c2 * fields(i1,j ,k,1) + & + c3 * fields(i,j1,k,1) + c4 * fields(i1,j1,k,1) + vp = c1 * fields(i,j ,k,2) + c2 * fields(i1,j ,k,2) + & + c3 * fields(i,j1,k,2) + c4 * fields(i1,j1,k,2) + wp = c1 * fields(i,j ,k,3) + c2 * fields(i1,j ,k,3) + & + c3 * fields(i,j1,k,3) + c4 * fields(i1,j1,k,3) + + if (k.eq.nz) then + ! if the particle is in the last layer, add velocities from wrk0 + up = up + & + c5 * wrk(i,j ,1,0) + c6 * wrk(i1,j ,1,0) + & + c7 * wrk(i,j1,1,0) + c8 * wrk(i1,j1,1,0) + vp = vp + & + c5 * wrk(i,j ,2,0) + c6 * wrk(i1,j ,2,0) + & + c7 * wrk(i,j1,2,0) + c8 * wrk(i1,j1,2,0) + wp = wp + & + c5 * wrk(i,j ,3,0) + c6 * wrk(i1,j ,3,0) + & + c7 * wrk(i,j1,3,0) + c8 * wrk(i1,j1,3,0) + else + ! if the particle is inside the slice, straightforward interpolation + up = up + & + c5 * fields(i,j ,k+1,1) + c6 * fields(i1,j ,k+1,1) + & + c7 * fields(i,j1,k+1,1) + c8 * fields(i1,j1,k+1,1) + vp = vp + & + c5 * fields(i,j ,k+1,2) + c6 * fields(i1,j ,k+1,2) + & + c7 * fields(i,j1,k+1,2) + c8 * fields(i1,j1,k+1,2) + wp = wp + & + c5 * fields(i,j ,k+1,3) + c6 * fields(i1,j ,k+1,3) + & + c7 * fields(i,j1,k+1,3) + c8 * fields(i1,j1,k+1,3) + end if + + ! now move the particle + + if (uvwp(1,n).eq.-999.0d0) then + ! if the second slice is unavailable, use Euler + xp = xp + dt * up / dx + yp = yp + dt * vp / dy + zp = zp + dt * wp / dz + else + ! if there is the second slice, use Adams-Bashforth + xp = xp + (1.50d0*up - 0.50d0*uvwp(1,n)) * dt/dx + yp = yp + (1.50d0*vp - 0.50d0*uvwp(2,n)) * dt/dy + zp = zp + (1.50d0*wp - 0.50d0*uvwp(3,n)) * dt/dz + end if + + ! update the velocities + uvwp(1,n) = up + uvwp(2,n) = vp + uvwp(3,n) = wp + + ! apply periodicity in x- and y-directions + ! also count the # of particles to be sent to neibour slices + ! note that we assume that the particle cannot move further than one cell + ! from its curent position + + ! x direction + if (xp.gt.1.0d0) then + xp = xp - 1.0d0 + i = i+1 + if (i.gt.nx) i = i - nx + end if + if (xp.lt.0.0d0) then + xp = xp + 1.0d0 + i = i-1 + if (i.lt.1) i = i + nx + end if + + ! y direction + if (yp.gt.1.0d0) then + yp = yp - 1.0d0 + j = j+1 + if (j.gt.ny) j = j - ny + end if + if (yp.lt.0.0d0) then + yp = yp + 1.0d0 + j = j-1 + if (j.lt.1) j = j + ny + end if + + ! z direction + if (zp.gt.1.0d0) then + zp = zp - 1.0d0 + k = k+1 + if (k.gt.nz) np_send_u = np_send_u + 1 + end if + if (zp.lt.0.0d0) then + zp = zp + 1.0d0 + k = k-1 + if (k.lt.1) np_send_d = np_send_d + 1 + end if + + + ! updating the particle coordinates. + ! note that z-coordinate can be outside of the slab + xyzp(1,n) = xp + dble(i) + xyzp(2,n) = yp + dble(j) + xyzp(3,n) = zp + dble(k) + + end do + + return + end subroutine particles_interpolate_trilinear + + +!================================================================================ +!================================================================================ +! Moving Lagrangian particles. The velocity is interpolated using tricubic +! interpolation method, found in Wikipedia :) +!================================================================================ + subroutine particles_interpolate_cint + + use m_fields + use m_work + implicit none + + ! local variables + integer :: ip,jp,kp,i,j,k,i1,j1,k1,n + real*8 :: xp,yp,zp,up,vp,wp + real*8 :: sctmp + real*8 :: uloc(4,4,4), vloc(4,4,4), wloc(4,4,4) +! real*8 :: cint_3d + + real*8 :: r + + ! making sure that the thickness of the slabs is mroe than 1 slice + if (nz.lt.2) then + write(out,*) "PARTICLES_MOVE_CINT: nz is less than 2, stopping" + call flush(out) + stop 'particles_move_cint *** nz less than 2' + end if + + ! assuming that array fields1...3 has the velocities in X-space + + ! because this method involves the adjacent 26 cells (a 4x4 cube of points + ! in which the particle occupies the central cell), we need to pass the + ! first two slices "down" and the last single slice (nz) "up" + + ! sending/receiving the single slice + ! sending "up" + ! receiving from "down" + + count = (nx+2) * ny + id_from = mod(myid - 1 + numprocs, numprocs); + id_to = mod(myid + 1 , numprocs); + + sendtag = 6 * myid + 0 + recvtag = 6 * id_from + 0 + call MPI_IRECV( wrk(1,1,1, 1), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,nz,1), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + sendtag = 6 * myid + 1 + recvtag = 6 * id_from + 1 + call MPI_IRECV( wrk(1,1,1, 2), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,nz,2), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + sendtag = 6 * myid + 2 + recvtag = 6 * id_from + 2 + call MPI_IRECV( wrk(1,1,1, 3), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,nz,3), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + ! sending/receiving two slicee + ! sending "down" + ! receiving from "up" + + count = 2 * (nx+2) * ny + id_from = mod(myid + 1 , numprocs); + id_to = mod(myid - 1 + numprocs, numprocs); + + sendtag = 6 * myid + 3 + recvtag = 6 * id_from + 3 + call MPI_IRECV( wrk(1,1,2,1), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,1), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + sendtag = 6 * myid + 4 + recvtag = 6 * id_from + 4 + call MPI_IRECV( wrk(1,1,2,2), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,2), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + sendtag = 6 * myid + 5 + recvtag = 6 * id_from + 5 + call MPI_IRECV( wrk(1,1,2,3), count, MPI_REAL8, id_from, recvtag, MPI_COMM_TASK, request, mpi_err) + call MPI_SEND(fields(1,1,1,3), count, MPI_REAL8, id_to , sendtag, MPI_COMM_TASK, mpi_err) + call MPI_WAIT(request, mpi_status, mpi_err) + + ! # of particles to be sent/received to/from "down" and "up" + np_send_u = 0 + np_send_d = 0 + np_get_u = 0 + np_get_d = 0 + + do n = 1,np + + ! getting the cell where the particle is at + ip = floor(xyzp(1,n)) + jp = floor(xyzp(2,n)) + kp = floor(xyzp(3,n)) + + ! getting fractional coordinates of the particle + xp = xyzp(1,n) - dble(ip) + yp = xyzp(2,n) - dble(jp) + zp = xyzp(3,n) - dble(kp) + + ! ------------------------------------------------------------------- + ! Getting the velocities of the particles by tricubic interpolation + ! (for particularities, see notes from 12/13/07) + + ! fillin out arrays uloc, vloc, and wloc(4,4,4) for tricubic interpolation + ! taking into account periodicity in x and y. + + do k = 1,4 + k1 = kp - 2 + k + + do j = 1,4 + j1 = jp - 2 + j + if (j1.lt.1 ) j1 = j1 + ny + if (j1.gt.ny) j1 = j1 - ny + + do i = 1,4 + i1 = ip - 2 + i + if (i1.lt.1 ) i1 = i1 + nx + if (i1.gt.nx) i1 = i1 - nx + + if (k1.lt.1) then + uloc(i,j,k) = wrk(i1,j1,1,1) + vloc(i,j,k) = wrk(i1,j1,1,2) + wloc(i,j,k) = wrk(i1,j1,1,3) + else if (k1.gt.nz) then + uloc(i,j,k) = wrk(i1,j1,k1-nz+1,1) + vloc(i,j,k) = wrk(i1,j1,k1-nz+1,2) + wloc(i,j,k) = wrk(i1,j1,k1-nz+1,3) + else + uloc(i,j,k) = fields(i1,j1,k1,1) + vloc(i,j,k) = fields(i1,j1,k1,2) + wloc(i,j,k) = fields(i1,j1,k1,3) + end if + + end do + end do + end do + + ! now we have arrays uloc, vloc, wloc and can interpolate + + up = cint_3d(uloc,xp,yp,zp) + vp = cint_3d(vloc,xp,yp,zp) + wp = cint_3d(wloc,xp,yp,zp) + + ! now move the particle + + if (uvwp(1,n).eq.-999.0d0) then + ! if the second slice is unavailable, use Euler + xp = xp + dt * up / dx + yp = yp + dt * vp / dy + zp = zp + dt * wp / dz + else + ! if there is the second slice, use Adams-Bashforth + xp = xp + (1.50d0*up - 0.50d0*uvwp(1,n)) * dt/dx + yp = yp + (1.50d0*vp - 0.50d0*uvwp(2,n)) * dt/dy + zp = zp + (1.50d0*wp - 0.50d0*uvwp(3,n)) * dt/dz + end if + + uvwp(1,n) = up + uvwp(2,n) = vp + uvwp(3,n) = wp + + + ! apply periodicity in x- and y-directions + ! also count the # of particles to be sent to neibour slices + ! note that we assume that the particle cannot move further than one cell + ! from its curent position + + ! x direction + if (xp.gt.1.0d0) then + xp = xp - 1.0d0 + ip = ip+1 + if (ip.gt.nx) ip = ip - nx + end if + if (xp.lt.0.0d0) then + xp = xp + 1.0d0 + ip = ip-1 + if (ip.lt.1) ip = ip + nx + end if + + ! y direction + if (yp.gt.1.0d0) then + yp = yp - 1.0d0 + jp = jp+1 + if (jp.gt.ny) jp = jp - ny + end if + if (yp.lt.0.0d0) then + yp = yp + 1.0d0 + jp = jp-1 + if (jp.lt.1) jp = jp + ny + end if + + ! z direction + if (zp.gt.1.0d0) then + zp = zp - 1.0d0 + kp = kp+1 + if (kp.gt.nz) np_send_u = np_send_u + 1 + end if + if (zp.lt.0.0d0) then + zp = zp + 1.0d0 + kp = kp-1 + if (kp.lt.1) np_send_d = np_send_d + 1 + end if + + + ! updating the particle coordinates. + ! note that z-coordinate can be outside of the slice + xyzp(1,n) = xp + dble(ip) + xyzp(2,n) = yp + dble(jp) + xyzp(3,n) = zp + dble(kp) + + end do + + + return + end subroutine particles_interpolate_cint + + + +!================================================================================ +!================================================================================ + subroutine particles_update_slabs + + use m_openmpi + use m_work + implicit none + + integer (kind=MPI_INTEGER_KIND) :: id_down, id_up + + integer :: i, j, n, iii + + + id_down = mod(myid-1+numprocs,numprocs) + id_up = mod(myid+1,numprocs) + +!!$ write(out,*) "np_sends:", np_send_d, np_send_u +!!$ call flush(out) + + ! let the neighbors know how many particles went to them + call MPI_SEND(np_send_d,1,MPI_INTEGER4,id_down,2*myid ,MPI_COMM_TASK,mpi_err) + call MPI_SEND(np_send_u,1,MPI_INTEGER4,id_up ,2*myid+1,MPI_COMM_TASK,mpi_err) + + ! learn how many particles will be transferred to this slice from neighbors + call MPI_RECV(np_get_d,1,MPI_INTEGER4,id_down,2*id_down+1,MPI_COMM_TASK,mpi_status,mpi_err) + call MPI_RECV(np_get_u,1,MPI_INTEGER4,id_up ,2*id_up ,MPI_COMM_TASK,mpi_status,mpi_err) + + +!!$ write(out,*) "np_gets:", np_get_d, np_get_u +!!$ call flush(out) + + ! rearranging particles in the following order: + ! 1. particles that stay + ! 2. particles that leave down + ! 3. particles that leave up + + if (np_send_u.gt.0) then + i = 1 + n = np + do while (i.le.n) + if (xyzp(3,i).ge.dble(nz+1)) then + wrk(1:3,1,1,0) = xyzp(1:3,i) + wrk(4:6,1,1,0) = uvwp(1:3,i) + j = ipart(i) + + xyzp(:,i) = xyzp(:,n) + uvwp(:,i) = uvwp(:,n) + ipart(i) = ipart(n) + + xyzp(1:3,n) = wrk(1:3,1,1,0) + uvwp(1:3,n) = wrk(4:6,1,1,0) + xyzp(3,n) = xyzp(3,n) - dble(nz) + ipart(n) = j + + n = n - 1 + + else + i = i + 1 + end if + end do + end if + + if (np_send_d.gt.0) then + i = 1 + n = np - np_send_u + do while (i.le.n) + if (xyzp(3,i).lt.1.0d0) then + wrk(1:3,1,1,0) = xyzp(1:3,i) + wrk(4:6,1,1,0) = uvwp(1:3,i) + j = ipart(i) + + xyzp(:,i) = xyzp(:,n) + uvwp(:,i) = uvwp(:,n) + ipart(i) = ipart(n) + + xyzp(1:3,n) = wrk(1:3,1,1,0) + uvwp(1:3,n) = wrk(4:6,1,1,0) + xyzp(3,n) = xyzp(3,n) + dble(nz) + ipart(n) = j + + n = n - 1 + else + i = i + 1 + end if + end do + end if + + + ! sending and receiving particiles from adjacent slabs + + ! extra arrays (a dumb way to avoid deadlocking in send/receive when + ! number of particles is large and the send/receive is not completed in the + ! single handshake between the two processes) + + xyzp1 = xyzp + uvwp1 = uvwp + ipart1 = ipart + + np1 = np + np = np - np_send_d - np_send_u + + ! posting receive from down + if (np_get_d.gt.0) then + call MPI_IRECV(xyzp(1,np+1),3*np_get_d,MPI_REAL8 ,id_down,6*id_down+0,MPI_COMM_TASK,request1,mpi_err) + call MPI_IRECV(uvwp(1,np+1),3*np_get_d,MPI_REAL8 ,id_down,6*id_down+1,MPI_COMM_TASK,request2,mpi_err) + call MPI_IRECV( ipart(np+1),np_get_d,MPI_INTEGER8,id_down,6*id_down+2,MPI_COMM_TASK,request3,mpi_err) + +!!$ write(out,*) 'posted receive from ',id_down +!!$ call flush(out) + + end if + + ! sending particles to up + if (np_send_u.gt.0) then + +!!$ write(out,*) 'xyzp1' +!!$ write(out,"(3e15.6)") (xyzp1(:,iii),iii=1,np) +!!$ write(out,*) 'uvwp1' +!!$ write(out,"(3e15.6)") (uvwp1(:,iii),iii=1,np) +!!$ write(out,*) 'ipart1' +!!$ write(out,"(i5)") (ipart(iii),iii=1,np) +!!$ call flush(out) + + call MPI_SEND(xyzp1(1,np1-np_send_u+1),3*np_send_u,MPI_REAL8 ,id_up,6*myid+0,MPI_COMM_TASK,mpi_err) + call MPI_SEND(uvwp1(1,np1-np_send_u+1),3*np_send_u,MPI_REAL8 ,id_up,6*myid+1,MPI_COMM_TASK,mpi_err) + call MPI_SEND( ipart1(np1-np_send_u+1),np_send_u,MPI_INTEGER4,id_up,6*myid+2,MPI_COMM_TASK,mpi_err) + +!!$ write(out,*) 'sent',np_send_u,' to the right:', ipart1(np1-np_send_u+1:np1) +!!$ call flush(out) + + np1 = np1 - np_send_u + + end if + + ! completing the receive from the down + if (np_get_d.gt.0) then + call MPI_WAIT(request1,mpi_status,mpi_err) + call MPI_WAIT(request2,mpi_status,mpi_err) + call MPI_WAIT(request3,mpi_status,mpi_err) + +!!$ write(out,*) 'received',np_get_d,' from the left:', ipart(np+1:np+np_get_d) +!!$ call flush(out) + + np = np + np_get_d + + end if + + + + ! posting receive from the up + if (np_get_u.gt.0) then + call MPI_IRECV(xyzp(1,np+1),3*np_get_u,MPI_REAL8 ,id_up,6*id_up+3,MPI_COMM_TASK,request1,mpi_err) + call MPI_IRECV(uvwp(1,np+1),3*np_get_u,MPI_REAL8 ,id_up,6*id_up+4,MPI_COMM_TASK,request2,mpi_err) + call MPI_IRECV( ipart(np+1),np_get_u ,MPI_INTEGER8,id_up,6*id_up+5,MPI_COMM_TASK,request3,mpi_err) + +!!$ write(out,*) 'posted receive from ',id_up +!!$ call flush(out) + + end if + + + ! sending particles to down + if (np_send_d.gt.0) then + call MPI_SEND(xyzp1(1,np1-np_send_d+1),3*np_send_d,MPI_REAL8 ,id_down,6*myid+3,MPI_COMM_TASK,mpi_err) + call MPI_SEND(uvwp1(1,np1-np_send_d+1),3*np_send_d,MPI_REAL8 ,id_down,6*myid+4,MPI_COMM_TASK,mpi_err) + call MPI_SEND( ipart1(np1-np_send_d+1),np_send_d ,MPI_INTEGER4,id_down,6*myid+5,MPI_COMM_TASK,mpi_err) + +!!$ write(out,*) 'sent',np_send_d,' to the left:', ipart(np1-np_send_d+1:np1) +!!$ call flush(out) + + end if + + ! completing the receive from up + if (np_get_u.gt.0) then + call MPI_WAIT(request1,mpi_status,mpi_err) + call MPI_WAIT(request2,mpi_status,mpi_err) + call MPI_WAIT(request3,mpi_status,mpi_err) + +!!$ write(out,*) 'received',np_get_u,' from the right:', ipart(np+1:np+np_get_u) +!!$ call flush(out) + + np = np + np_get_u + + end if + + + + ! writing out particles' locations to separate files for each particle +!!$ if (mod(ITIME,IWRITE4).eq.0) then + + if (nptot.lt.1000) then + do i=1,np + + write(fname,"('p.',i4.4)") ipart(i) + open(99,file=fname,position='append') + write(99,'(i6.6,x, i4, 12e16.8)') & + itime,myid,time,(xyzp(1:2,i)-1.0d0)*dx,(xyzp(3,i)-1.0d0+dble(myid*nz))*dz,& + uvwp(:,i) + close(99) + end do + end if + +!!$ end if + + + + + return + end subroutine particles_update_slabs + + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ + +!================================================================================ + function cint_3d(a,x,y,z) result (blah) + + implicit none + real*8 :: blah + real*8 :: a(4,4,4), x, y, z + + logical :: compute_r + integer :: j, k + real*8 :: t2(4,4), t1(4), r(4) + + blah = 0.0d0 + + compute_r = .true. + do k = 1,4 + do j = 1,4 + t2(j,k) = cint(a(1,j,k),a(2,j,k),a(3,j,k),a(4,j,k),x,r,compute_r) + if (compute_r) compute_r = .false. + end do + end do + + compute_r = .true. + do k = 1,4 + t1(k) = cint(t2(1,k),t2(2,k),t2(3,k),t2(4,k),y,r,compute_r) + if (compute_r) compute_r = .false. + end do + + blah = cint(t1(1),t1(2),t1(3),t1(4),z,r,.true.) + + return + end function cint_3d + + +!================================================================================ + + function cint(p1,p2,p3,p4,x,r,compute_r) result (blah) + implicit none + logical :: compute_r + real*8 :: p1,p2,p3,p4,x,r(4) + + real*8 :: sctmp + + real*8 :: blah + + ! If flag=.true., compute vector R(x) + ! If flag=.false., consider vector R(x) defined and do not compute it + if (compute_r) then + sctmp = (x - 1.d0) * (x - 2.d0) + r(1) = -x * sctmp + r(2) = 3.d0 * (x + 1.d0) * sctmp + sctmp = (x + 1) * x + r(3) = -3.d0 * sctmp * (x - 2.d0) + r(4) = sctmp * (x - 1.d0) + end if + + blah = (r(1)*p1 + r(2)*p2 + r(3)*p3 + r(4)*p4) / 6.0d0 + + return + end function cint + + + +end module m_particles diff --git a/m_rand_knuth.f90 b/m_rand_knuth.f90 new file mode 100644 index 0000000..a121ffa --- /dev/null +++ b/m_rand_knuth.f90 @@ -0,0 +1,155 @@ +MODULE m_rand_knuth + + + ! Random number generator + + + ! Code converted using TO_F90 by Alan Miller + ! Date: 2000-09-10 Time: 16:37:48 + ! Latest revision - 16 January 2003 + + ! FORTRAN 77 version of "ran_array" + ! from Seminumerical Algorithms by D E Knuth, 3rd edition (1997) + ! including the MODIFICATIONS made in the 9th printing (2002) + ! ********* see the book for explanations and caveats! ********* + ! Author: Steve Kifowit + ! http://ourworld.compuserve.com/homepages/steve_kifowit + ! with modifications by Alan Miller to rnarry and rnstrt based upon + ! Knuth's code. + + ! For Donald Knuth's Fortran 77 versions, go to: + ! http://www-cs-faculty.stanford.edu/~knuth/programs + ! Look for frng.f and frngdb.f + + IMPLICIT NONE + INTEGER, PARAMETER :: kk=100, ll=37, mm=2**30, tt=70, kkk=kk+kk-1 + INTEGER, SAVE :: ranx(kk) + +CONTAINS + + + SUBROUTINE rand_knuth(u, n) + + ! Generate an array of n real values between 0 and 1. + + REAL , INTENT(OUT) :: u(:) + INTEGER, INTENT(IN) :: n + + ! Local array + INTEGER :: aa(n) + + CALL rnarry(aa, n) + u(1:n) = SCALE( REAL(aa), -30) + + RETURN + END SUBROUTINE rand_knuth + + + + SUBROUTINE rnarry(aa, n) + + ! Generate an array of n integers between 0 and 2^30-1. + + INTEGER, INTENT(OUT) :: aa(:) + INTEGER, INTENT(IN) :: n + + ! Local variables + INTEGER :: j + + aa(1:kk) = ranx(1:kk) + DO j = kk + 1, n + aa(j) = aa(j-kk) - aa(j-ll) + IF (aa(j) < 0) aa(j) = aa(j) + mm + END DO + DO j=1,ll + ranx(j) = aa(n+j-kk) - aa(n+j-ll) + IF (ranx(j) < 0) ranx(j) = ranx(j) + mm + END DO + DO j=ll+1,kk + ranx(j) = aa(n+j-kk) - ranx(j-ll) + IF (ranx(j) < 0) ranx(j) = ranx(j) + mm + END DO + + RETURN + END SUBROUTINE rnarry + + + + SUBROUTINE rand_knuth_start(seed) + + ! Initialize integer array ranx using the input seed. + + INTEGER*8, INTENT(IN) :: seed + + ! Local variables + INTEGER :: x(kkk), j, ss, sseed, t + + IF (seed < 0) THEN + sseed = mm - 1 - MOD(-1-seed, mm) + ELSE + sseed = MOD(seed, mm) + END IF + ss = sseed - MOD(sseed,2) + 2 + DO j=1, kk + x(j) = ss + ss = ISHFT(ss, 1) + IF (ss >= mm) ss = ss - mm + 2 + END DO + x(kk+1:kkk) = 0 + x(2) = x(2)+1 + ss = sseed + t = tt - 1 +10 DO j=kk, 2, -1 + x(j+j-1) = x(j) + END DO + DO j = kkk, kk + 1, -1 + x(j-(kk-ll)) = x(j-(kk-ll)) - x(j) + IF (x(j-(kk-ll)) < 0) x(j-(kk-ll)) = x(j-(kk-ll)) + mm + x(j-kk) = x(j-kk) - x(j) + IF (x(j-kk) < 0) x(j-kk) = x(j-kk) + mm + END DO + IF (MOD(ss,2) == 1) THEN + DO j=kk, 1, -1 + x(j+1) = x(j) + END DO + x(1) = x(kk+1) + x(ll+1) = x(ll+1) - x(kk+1) + IF (x(ll+1) < 0) x(ll+1) = x(ll+1) + mm + END IF + IF (ss /= 0) THEN + ss = ISHFT(ss, -1) + ELSE + t = t - 1 + END IF + IF (t > 0) GO TO 10 + + DO j=1, ll + ranx(j+kk-ll) = x(j) + END DO + DO j=ll+1,kk + ranx(j-ll) = x(j) + END DO + + DO j = 1, 10 + CALL rnarry(x,kkk) + END DO + + RETURN + END SUBROUTINE rand_knuth_start + + + ! Initialization subroutine + + subroutine rand_knuth_init(seed1) + + integer*8 :: seed1 + + call rand_knuth_start(seed1) + + + return + end subroutine rand_knuth_init + + +END MODULE m_rand_knuth + diff --git a/m_stats.f90 b/m_stats.f90 new file mode 100644 index 0000000..b651cb2 --- /dev/null +++ b/m_stats.f90 @@ -0,0 +1,445 @@ +module m_stats + + use m_parameters + + real*8, allocatable :: e_spec(:), e_spec1(:), moments(:,:), sc_diss(:), sc_min(:), sc_max(:) + integer*8, allocatable :: hits(:), hits1(:) + + real*8 :: energy, eps_v, eta, etakmax, enstrophy, re_lambda, uvar, x_length + real*8 :: lambda, re_lambda1, tau_e + real*8 :: sctmp + + +contains + +!================================================================================ +! This is a small module so the arrays get allocated in all parts of the code +!================================================================================ + + + subroutine m_stats_init + + implicit none + + allocate(e_spec(kmax), e_spec1(kmax), moments(3+n_scalars,4), hits(kmax), hits1(kmax),& + sc_diss(n_scalars), sc_min(n_scalars), sc_max(n_scalars),stat=ierr) + + write(out,*) "Stat allocated.", ierr + + e_spec = zip + e_spec1 = zip + hits = 0 + hits1 = 0 + sc_diss = zip + sc_min = zip + sc_max = zip + + + return + end subroutine m_stats_init + +!================================================================================ +!================================================================================ + + subroutine stat_main + + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: n + + logical :: there2 + + + real*8 :: fac, fac2 + + + call stat_velocity + + if (int_scalars) then + call stat_scalars + + ! now outputting the scalar statistics + do n = 1, n_scalars + if (myid.eq.0) then + + write(fname,"('sc',i2.2,'.gp')") n + inquire(file=fname, exist=there, opened=there2) + if (.not.there) then + open(100+n,file=fname,form='formatted') + write(100+n,'(A)') '# 1.itime 2.time 3.sc.diss 4. mean 5.variance 6.min 7.max' + end if + if(there.and..not.there2) then + open(100+n,file=fname,position='append') + end if + write(100+n,"(i7,10e15.6)") itime, time, sc_diss(n), moments(3+n,1:2), sc_min(n), sc_max(n) + call flush(100+n) + end if + end do + + end if + + if (task_split) then + write(out,9000) ITIME, TIME + call flush(out) + end if + + return +9000 format('ITIME=',i7,' TIME=',e15.7,' Stat files are written.') + end subroutine stat_main + + + +!================================================================================ + + subroutine stat_velocity + + implicit none + + logical :: there2 + + integer :: k, n + + ! getting the enstrophy + call get_gradient_statistics + + ! getting the energy spectrum e_spec to the main process + call get_e_spec + + + ! outputting the statistics into files + if (myid.eq.0) then + + ! getting the total energy + energy = sum(e_spec(1:kmax)) + + + ! finding dissipation spectrum and total dissipation + do k = 1,kmax + e_spec1(k) = e_spec(k) * real(k**2,8) * two * nu + end do + eps_v = sum(e_spec1(1:kmax)) + + ! finding Kolmogorov scale + eta = (nu**3/eps_v)**0.25 + etakmax = eta * real(kmax,8) + + ! variance + uvar = two/three*energy + ! integral length scale + sctmp = zip + do k = 1, kmax + sctmp = sctmp + e_spec(k) / real(k,8) + end do + x_length = PI / two * sctmp / uvar + + ! Taylor microscale + lambda = sqrt(15.d0 * uvar * nu / eps_v) + + ! Taylor-Reynolds number + re_lambda = uvar*sqrt(15.d0/eps_v*RE) + re_lambda1 = sqrt(uvar)*lambda / nu + + ! Eddy turnover time + tau_e = x_length / sqrt(uvar) + + ! outputting all this in the stat1 file + + inquire(file='stat1.gp', exist=there, opened=there2) + if (.not.there) then + open(69,file='stat1.gp',form='formatted') + write(69,*) '# 1.itime 2.time 3.energy 4.diss 5.eta 6.enstrophy 7.R_lambda' + end if + if(there.and..not.there2) then + open(69,file='stat1.gp',position='append') + end if + write(69,"(i8,20e15.6)") itime, time, energy, eps_v, eta, enstrophy, re_lambda + call flush(69) + + ! outputting all this in the stat2 file + + inquire(file='stat2.gp', exist=there, opened=there2) + if (.not.there) then + open(70,file='stat2.gp',form='formatted') + write(70,'(A)') '# 1.itime 2.time 3.int LS 4. lambda 5.R_lambda1 6.tau_e 7.etakmax' + end if + if(there.and..not.there2) then + open(70,file='stat2.gp',position='append') + end if + write(70,"(i8,20e15.6)") itime, time, x_length, lambda, re_lambda1, tau_e, etakmax + call flush(70) + + + ! outputting the energy spectrum + open(900,file='es.gp',position='append') + write(900,"()") + write(900,"()") + write(900,"('# ITIME=',i7,' TIME=',e17.8)") ITIME, TIME + do k = 1,kmax !min(kmax,nx/3) + write(900,"(i4,2e15.6)") k,e_spec(k), e_spec1(k) + end do + close(900) + + end if + return + end subroutine stat_velocity + +!================================================================================ +!================================================================================ +!================================================================================ + + subroutine get_e_spec + + use m_io + use m_fields + use x_fftw + implicit none + + real*8 :: sc_rad1, sc_rad2, fac, fac2 + integer :: i, j, k, n_shell + + real*8 :: energy2 + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + e_spec1 = zip + e_spec = zip + + ! assembling the total energy in each shell and number of hits in each shell + do k = 1,nz + do j = 1,ny + do i = 1,nx + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + fac2 = fac * (fields(i,j,k,1)**2 + fields(i,j,k,2)**2 + fields(i,j,k,3)**2) + if (akx(i).eq.0.d0) fac2 = 0.5d0 * fac2 + e_spec1(n_shell) = e_spec1(n_shell) + fac2 + end if + + end do + end do + end do + + ! reducing the number of hits and energy to two arrays on master node + count = kmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + + return + end subroutine get_e_spec + + +!================================================================================- +!================================================================================- + + subroutine get_gradient_statistics + + use m_fields + use m_work + use x_fftw + + implicit none + integer :: i + real*8 :: fac + + ! normalization factor + fac = one / real(nx*ny*nz_all,8) + + do i = 1,3 + wrk(:,:,:,i) = fields(:,:,:,i) + end do + + ! Taking derivatives + + call x_derivative(3,'y',6) + call x_derivative(3,'x',5) + + call x_derivative(2,'z',4) + call x_derivative(2,'x',3) + + call x_derivative(1,'z',2) + call x_derivative(1,'y',1) + +!------------------------------------------------------------ +! getting vorticity and enstrophy +!------------------------------------------------------------ + wrk(:,:,:,3) = wrk(:,:,:,3) - wrk(:,:,:,1) ! omega_3 = v_x - u_y + wrk(:,:,:,2) = wrk(:,:,:,2) - wrk(:,:,:,5) ! omega_2 = u_z - w_x + wrk(:,:,:,1) = wrk(:,:,:,6) - wrk(:,:,:,4) ! omega_1 = w_y - v_z + + call xFFT3d(-1,1) + call xFFT3d(-1,2) + call xFFT3d(-1,3) + + ! getting mean enstrophy + wrk(:,:,:,0) = wrk(:,:,:,1)**2 + wrk(:,:,:,2)**2 + wrk(:,:,:,3)**2 + + sctmp = sum(wrk(1:nx,:,:,0)) * fac + count = 1 + call MPI_REDUCE(sctmp,enstrophy,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + +!------------------------------------------------------------ + return + end subroutine get_gradient_statistics + +!================================================================================ +!================================================================================ +!================================================================================ + + subroutine stat_scalars + + + use m_openmpi + use m_fields + use m_work + use x_fftw + implicit none + + integer :: i, j, k, n + real*8 :: q1, q2, fac + + + if (.not. int_scalars) return + + ! getting the spectra of the scalar variances + call get_scalar_spectra + + + ! scaling factor + fac = one / real(nx*ny*nz_all) + + ! --- Calculating moments of scalars + do n = 1, n_scalars + + ! putting the scalar in wrk0 + wrk(:,:,:,0) = fields(:,:,:,3+n) + + ! taking derivatives + call x_derivative(0,'x',1) + call x_derivative(0,'y',2) + call x_derivative(0,'z',3) + + ! converting the derivatives to X-space + call xFFT3d(-1,1) + call xFFT3d(-1,2) + call xFFT3d(-1,3) + + ! getting the dissipation rate of the variance + wrk(:,:,:,4) = wrk(:,:,:,1)**2 + wrk(:,:,:,2)**2 + wrk(:,:,:,3)**2 + q1 = two * pe(n) * sum(wrk(1:nx,:,:,4)) * fac + count = 1 + call MPI_REDUCE(q1,q2,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + if (myid.eq.0) sc_diss(n) = q2 + + ! converting the scalar itself to X-space + call xFFT3d(-1,0) + + ! First moment - mean + q1 = sum(wrk(1:nx,:,:,0)) * fac + count = 1 + call MPI_REDUCE(q1,q2,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + if (myid.eq.0) moments(3+n,1) = q2 + + ! Second moment - variance + q1 = sum(wrk(1:nx,:,:,0)**2) * fac + count = 1 + call MPI_REDUCE(q1,q2,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + if (myid.eq.0) moments(3+n,2) = q2 - moments(3+n,1)**2 + + ! Min and max of the scalar + q1 = minval(wrk(1:nx,:,:,0)) + q2 = maxval(wrk(1:nx,:,:,0)) + count = 1 + call MPI_REDUCE(q1,sc_min(n),count,MPI_REAL8,MPI_MIN,0,MPI_COMM_TASK,mpi_err) + call MPI_REDUCE(q2,sc_max(n),count,MPI_REAL8,MPI_MAX,0,MPI_COMM_TASK,mpi_err) + + end do + + + return + end subroutine stat_scalars + +!================================================================================ +!================================================================================ + + subroutine get_scalar_spectra + + use m_io + use m_fields + use x_fftw + implicit none + + real*8 :: sc_rad1, sc_rad2, fac, fac2 + integer :: i, j, k, n, n_shell + + real*8 :: energy2 + + ! cycle over the scalars + do n = 1,n_scalars + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + ! using the neergy spectra arrays to keep the scalar spectra + e_spec1 = zip + e_spec = zip + hits = 0 + hits1 = 0 + + ! assembling the total scalar energy in each shell and number of hits in each shell + do k = 1,nz + do j = 1,ny + do i = 1,nx + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + fac2 = fac * fields(i,j,k,3+n)**2 + if (akx(i).eq.0.d0) fac2 = 0.5d0 * fac2 + e_spec1(n_shell) = e_spec1(n_shell) + fac2 + end if + + end do + end do + end do + + ! reducing the energy to two arrays on master node + count = kmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + + ! now the master node counts the energy density in each shell + master_node: if (myid.eq.0) then + + + ! multiplying by two because we summed only half of the scalar energy + e_spec = 2.d0 * e_spec + + ! now the master node puts the scalar energy in the file es_sc##.gp + write(fname,"('es_',i2.2,'.gp')") n + open(900,file=fname,position='append') + write(900,"()") + write(900,"()") + write(900,"('# ITIME=',i7,' TIME=',e17.8)") ITIME, TIME + do k = 1,kmax + write(900,"(i4,4e15.6)") k,e_spec(k) + end do + close(900) + + end if master_node + + end do + + + return + end subroutine get_scalar_spectra + + +!================================================================================ +!================================================================================ +end module m_stats diff --git a/m_timing.f90 b/m_timing.f90 new file mode 100644 index 0000000..a627a54 --- /dev/null +++ b/m_timing.f90 @@ -0,0 +1,75 @@ +module m_timing + + integer*8 :: cpu0, cpu1, cpu2, dcpu + integer*4 :: cpu_sec, cpu_min, cpu_hrs, cpu_min_total + integer*4 :: job_runlimit + +!================================================================================ + +contains +!================================================================================ + subroutine get_job_runlimit + + use m_openmpi + use m_io + implicit none + + logical :: there + + ! make the default job runlimit to be 6 months + job_runlimit = 6 * 30 * 24 * 60 + + ! make the default job runlimit to be 12 hours + job_runlimit = 12 * 60 + + write(out,*) 'job_runlimit (default):',job_runlimit + + if(myid_world.eq.0) then + + inquire(file='job_parameters.txt',exist=there) + if (there) then + open(98,file='job_parameters.txt') + read(98,*,err=5) job_runlimit +5 close(98) + end if + end if + call MPI_BCAST(job_runlimit,1,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) + + write(out,*) 'job_runlimit: ',job_runlimit + call flush(out) + + return + + end subroutine get_job_runlimit + +!================================================================================ +!================================================================================ + + subroutine m_timing_init + + call system_clock(cpu0,dcpu) + return + end subroutine m_timing_init + +!================================================================================ +!================================================================================ + subroutine m_timing_check + + + use m_openmpi + implicit none + + call system_clock(cpu1,dcpu) + cpu_sec = (cpu1-cpu0)/dcpu + cpu_min = cpu_sec/60; cpu_min_total = cpu_min + cpu_hrs = cpu_min/60 + cpu_min = mod(cpu_min,60) + cpu_sec = mod(cpu_sec,60) + +!!$ call MPI_BCAST(cpu_hrs,1,MPI_INTEGER4,master,MPI_COMM_TASK,mpi_err) +!!$ call MPI_BCAST(cpu_min,1,MPI_INTEGER4,master,MPI_COMM_TASK,mpi_err) + + return + end subroutine m_timing_check + +end module m_timing diff --git a/m_work.f90 b/m_work.f90 new file mode 100644 index 0000000..c6f34cf --- /dev/null +++ b/m_work.f90 @@ -0,0 +1,149 @@ +!================================================================================ +! M_WORK - module that contains working arrays wrk1....wrk15. +! +! Time-stamp: <2009-08-18 13:47:59 (chumakov)> +!================================================================================ +module m_work + +! use m_openmpi + use m_parameters + use m_io + + + implicit none + + ! --- work arrays + real*4,allocatable :: tmp4(:,:,:) + + real*8, allocatable :: wrk(:,:,:,:) + + real*8, allocatable :: wrkp(:,:) + + real*8, allocatable :: rhs_old(:,:,:,:) + +contains + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ + subroutine m_work_init + + use m_parameters + implicit none + +!!$ write(out,*) "Inside m_work_init: ",task +!!$ call flush(out) + + ! allocating work arrays + if (task.eq.'hydro') then + + if (les_model.ge.4) then + ! The dynamic structure LES model needs more wrk arrays than usual + call m_work_allocate(max(6,3+n_scalars+n_les+4)) + else + call m_work_allocate(max(6,3+n_scalars+n_les+2)) + end if + + elseif (task.eq.'stats') then + + call m_work_allocate(6) + + elseif (task.eq.'parts') then + + ! required recources are different for the "parts" part of the code + ! we need several layers of velocities for velocity interpolation + select case (particles_tracking_scheme) + case (0) + allocate(wrk(1:nx+2,1:ny,1:3,0:0),stat=ierr) + write(out,*) "Allocated wrk(1:nx+2,1:ny,1:3,0:0)", ierr + wrk = zip + case (1) + allocate(wrk(1:nx+2,1:ny,1:3,1:3),stat=ierr) + write(out,*) "Allocated wrk(1:nx+2,1:ny,1:3,1:3)", ierr + wrk = zip + case default + stop 'wrong particles_tracking_scheme' + end select + allocate(tmp4(nx,ny,nz), stat=ierr) + write(out,*) "Allocated tmp4." + call flush(out) + + else + write(out,*) 'TASK variable is set in such a way that I dont know how to allocate work arrays' + write(out,*) 'task = ',task + call my_exit(-1) + end if + +!!$ write(out,*) "Finished m_work_init" +!!$ call flush(out) + + return + end subroutine m_work_init + +!================================================================================ +!================================================================================ +! allocating and defining the prescribed number of arrays +!================================================================================ +!================================================================================ + + subroutine m_work_allocate(number) + + implicit none + integer :: number + integer :: i, ierr, ierr_total + + ierr = 0 + +!!$ write(out,"('Allocating work: ',i3)") number +!!$ call flush(out) + + ! array that is needed for output (nx,ny,nz) + allocate(tmp4(nx,ny,nz),stat=i); ierr = ierr + i; + + ! main working array, needed for FFT etc, so (nx+2,ny,nz) + allocate(wrk(nx+2,ny,nz,0:number),stat=i); ierr = ierr + i + + ! array for the spare RHS for Adams-Bashforth time-stepping scheme methods + if (task.eq.'hydro') then + allocate(rhs_old(nx+2,ny,nz,3+n_scalars+n_les),stat=i); ierr = ierr + i + end if + + if (ierr.ne.0) then + print *,'*** WORK_INIT: error in allocation, stopping. ',ierr + print *,'*** task = ',task + print *,'*** myid = ',myid + call my_exit(-1) + stop + end if + + if (allocated(wrk)) write(out,"('allocated wrk(nx+2,ny,nz,0:',i3,')')") number + if (allocated(rhs_old)) write(out,"('allocated rhs_old(nx+2,ny,nz,1:',i3,')')") 3+n_scalars+n_les + call flush(out) + + tmp4 = 0.0 + wrk = zip + if (allocated(rhs_old)) rhs_old = 0.d0 + + + return + end subroutine m_work_allocate + +!================================================================================ +!================================================================================ + + subroutine m_work_exit + implicit none + +! write(out,*) 'deallocaing tmp4'; call flush(out) + if (allocated(tmp4)) deallocate(tmp4) +! write(out,*) 'deallocaing wrk'; call flush(out) + if (allocated(wrk)) deallocate(wrk) +! write(out,*) 'deallocaing wrkp'; call flush(out) + if (allocated(wrkp)) deallocate(wrkp) + write(out,*) 'deallocated wrk arrays'; call flush(out) + + return + end subroutine m_work_exit + +end module m_work diff --git a/main.f90 b/main.f90 new file mode 100644 index 0000000..90896c9 --- /dev/null +++ b/main.f90 @@ -0,0 +1,356 @@ +program x_code + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + use m_stats + use m_timing + use m_force + use m_rand_knuth + use m_particles + use m_filter_xfftw + use m_les + + implicit none + + integer :: n + character :: sym + + call m_timing_init ! Setting the time zero + call m_openmpi_init + call m_io_init + call m_parameters_init + call m_les_init + call m_fields_init + call m_work_init + + + ! allocating and initializing FFTW arrays + call x_fftw_allocate(1) + call x_fftw_init + + call m_stats_init + call m_force_init + + ! allocating and initializing particles + if (task.eq.'parts') then + call particles_init + end if + + write(out,*) "IN THE PROGRAM." + call flush(out) + + ! initializing the random number generator + ! call rand_knuth_init + + ! getting the wallclock runlimit for the job + call get_job_runlimit + + +!----------------------------------------------------------------------- +! Starting from the beginning or from the saved flowfield +!----------------------------------------------------------------------- + if(ITMIN.eq.0) then + call begin_new + else + call begin_restart + endif + + ! Initializing the LES stuff + if (les) call m_les_begin + + ! checking divergence + if (task.eq.'hydro') call divergence + + + ! indicators whether to use first-order in time + ! for velocities and scalars + fov = .true. + fos = .true. + + + ! need to dealias the fields at the beginning + if (task.eq.'hydro') call dealias_all + + +!******************************************************************************** +! call benchmark +!******************************************************************************** + +!================================================================================ +! MAIN CYCLE +!================================================================================ + + do 100 ITIME=ITMIN+1,ITMAX + + ! getting the file extension for current iteration + call get_file_ext +!-------------------------------------------------------------------------------- +! now performing the core of the cycle. +! This is done with "if" rather than "select case" because if we're not +! splitting tasks then we want everything to be done consequently by the +! same set of processors. +! +! All the syncronization calls (fields_to_parts, fields_to_stats) will be +! called only if (task_split). +!-------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------- +! HYDRO PART +! note that even in the case where there is no task splitting, +! 'hydro' part is still there. all processors will have task = 'hydro' +!-------------------------------------------------------------------------------- + hydro: if (task.eq.'hydro') then + + ! ------------------------------------------------------------ + ! taking care of rescaling when running decaying turbulence + ! if the time just was divisible by TRESCALE + ! ------------------------------------------------------------ + if (flow_type.eq.0 .and. floor((time-dt)/TRESCALE) .lt. floor(time/TRESCALE)) then + ! ...and if we haven't rescaled NRESCALE times + if (floor(time/TRESCALE) .le. NRESCALE .and. itime.ne.1) then + write(out,*) "MAIN: Rescaling velocities" + call flush(out) + call velocity_rescale + ! after rescaling, the time-sceping needs to be first order + fov = .true.; fos = .true. + if (.not. task_split .and. mod(itime,iprint1).eq.0) call stat_main + end if + end if + + ! RHS for scalars + call rhs_scalars + + ! now the velocities in x-space are contained in wrk1...3 + ! if we are moving particles, then we want to send the velocity field + ! to the "parts" part of the code + if (task_split) call fields_to_parts + + + ! advance scalars - either Euler or Adams-Bashforth + if (int_scalars .or. n_les > 0) then + call flush(out) + n = 3 + n_scalars + n_les + + if (fos) then + rhs_old(:,:,:,4:n) = wrk(:,:,:,4:n) + fields(:,:,:,4:n) = fields(:,:,:,4:n) + dt * rhs_old(:,:,:,4:n) + fos = .false. + else + fields(:,:,:,4:n) = fields(:,:,:,4:n) + & + dt * ( 1.5d0 * wrk(:,:,:,4:n) - 0.5d0 * rhs_old(:,:,:,4:n) ) + rhs_old(:,:,:,4:n) = wrk(:,:,:,4:n) + end if + + end if + + ! RHS for velocities + call rhs_velocity + + ! adding forcing, if computing a forced flow + if (flow_type.eq.1) call force_velocity + + ! advance velocity - either Euler or Adams-Bashforth + if (fov) then + rhs_old(:,:,:,1:3) = wrk(:,:,:,1:3) + fields(:,:,:,1:3) = fields(:,:,:,1:3) + dt * rhs_old(:,:,:,1:3) + fov = .false. + else + fields(:,:,:,1:3) = fields(:,:,:,1:3) + & + dt * ( 1.5d0 * wrk(:,:,:,1:3) - 0.5d0 * rhs_old(:,:,:,1:3) ) + rhs_old(:,:,:,1:3) = wrk(:,:,:,1:3) + end if + + ! solve for pressure and update velocities so they are incompressible + call pressure + + ! advance the time + TIME = TIME + DT + + ! write the restart file if it's the time + if (mod(itime,IPRINT2).eq.0) call restart_write_parallel + + ! change the timestep in case we're running with variable timestep + if (variable_dt) call my_dt + + ! CPU usage statistics + if (mod(itime,iprint1).eq.0) then + call m_timing_check + if (mod(itime,iwrite4).eq.0) then + sym = "*" + else + sym = " " + end if + write(out,9000) itime,time,dt,courant,cpu_hrs,cpu_min,cpu_sec,& + sym,les_model_name + call flush(out) + end if + + if (mod(itime,iprint1).eq.0 .or. mod(itime,iwrite4).eq.0) then + + ! send the velocities to the "stats" part of the code for statistics + if (task_split) call fields_to_stats + ! checking if we need to stop the calculations due to simulation time + if (TIME.gt.TMAX) call my_exit(1) + + ! checking if we need to start advancing scalars + if (n_scalars.gt.0 .and. .not.int_scalars .and. time.gt.TSCALAR) then + int_scalars = .true. + call init_scalars + write(out,*) "Starting to move the scalars." + call flush(out) + end if + + end if + end if hydro +!-------------------------------------------------------------------------------- +! STATISTICS PART +!-------------------------------------------------------------------------------- + stats: if (task.eq.'stats' .or. .not.task_split) then + + if (mod(itime,iprint1).eq.0 .or. mod(itime,iwrite4).eq.0) then + ! if this is a separate set of processors, then... + stats_task_split: if (task_split) then + ! checking if we need to stop the calculations due to simulation time + if (TIME.gt.TMAX) call my_exit(1) + end if stats_task_split + + ! these are executed regardless of the processor configuration + if (task_split) call fields_to_stats + if (mod(itime,iprint1).eq.0) call stat_main + if (mod(itime,iwrite4).eq.0) call io_write_4 + + end if + end if stats + +!-------------------------------------------------------------------------------- +! PARTICLE PARTS +! NOTE: This is not enabled to work when not task_split. +! Need to return to it later. +! Currently the particles can be calculated only if we split the tasks due to +! requirements on the wrk array sizes in the particle interpolation routines. +!-------------------------------------------------------------------------------- + particles: if (task.eq.'parts') then + + call fields_to_parts + + if (int_particles) then + call particles_move + if (mod(itime,iwrite4).eq.0) call particles_restart_write_binary + end if + + if (mod(itime,iprint1).eq.0 .or. mod(itime,iwrite4).eq.0) then + if (TIME.gt.TMAX) call my_exit(1) + end if + end if particles +!!$!-------------------------------------------------------------------------------- +!!$! OTHER PARTS +!!$!-------------------------------------------------------------------------------- +!!$ +!!$ +!!$ write(out,*) "skipping the time step",ITIME +!!$ call flush(out) +!!$ +!!$ +!-------------------------------------------------------------------------------- +! COMMON PARTS +!-------------------------------------------------------------------------------- + + + ! every 10 iterations checking + ! 1) for the run time: are we getting close to the job_runlimit? + ! 2) for the user termination: is there a file "stop" in directory? + if (mod(ITIME,10).eq.0) then + + ! synchronize all processors, hard +!!$ call MPI_BARRIER(MPI_COMM_WORLD,mpi_err) + + if (myid_world.eq.0) call m_timing_check + count = 1 + call MPI_BCAST(cpu_min_total,count,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) + + ! allowing 5 extra minutes for writing restart file + ! note that for large-scale calculations (e.g. 1024^3) + ! the restart writing time can be long (up to 20 minutes or so). + ! this should be taken care of in the job submission script + ! via file job_parameters.txt + if (cpu_min_total+5 .gt. job_runlimit) call my_exit(2) + + ! user termination. If the file "stop" is in the directory, stop + inquire(file='stop',exist=there) + if (there) call my_exit(3) + end if + + + +100 continue +!================================================================================ + +!-------------------------------------------------------------------------------- +! In a case when we've gone to ITMAX, write the restart file +!-------------------------------------------------------------------------------- + + ITIME = ITIME-1 + if (task.eq.'hydro') call restart_write_parallel + call my_exit(0) + call m_openmpi_exit + + stop +9000 format('ITIME=',i6,3x,'TIME=',f8.4,4x,'DT=',f8.5,3x,'Courn= ',f6.4, & + 2x,'CPU:(',i4.4,':',i2.2,':',i2.2,')',x,a1,x,a3) + end program x_code + + +!============================================================================= + subroutine benchmark + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + use m_stats + use m_timing + use m_force + use m_rand_knuth + use m_particles + use m_filter_xfftw + use m_les + + implicit none + + integer :: n, nmax + + call m_timing_init + benchmarking = .true. + bm = 0 + + wrk(:,:,:,1) = fields(:,:,:,1) + + do n = 1, nmax + call xfft3d(1,1) + call xfft3d(-1,1) + end do + + if (myid.eq.0) then + write(out,*) "BENF: statistics on forward transform" + write(out,*) "BENF: R2C: ", bm(1)/nmax + write(out,*) "BENF: T13: ", bm(2)/nmax + write(out,*) "BENF: C2C: ", bm(3)/nmax + write(out,*) "BENF: =====" + write(out,*) "BENF: TOT: ", bm(11)/nmax + write(out,*) "BENB: statistics on backward transform" + write(out,*) "BENB: C2C: ", bm(4)/nmax + write(out,*) "BENB: T13: ", bm(5)/nmax + write(out,*) "BENB: C2R: ", bm(6)/nmax + write(out,*) "BENB: =====" + write(out,*) "BENB: TOT: ", bm(12)/nmax + end if + + close(out) + + stop +end subroutine benchmark diff --git a/my_dt.f90 b/my_dt.f90 new file mode 100644 index 0000000..b2b23f9 --- /dev/null +++ b/my_dt.f90 @@ -0,0 +1,34 @@ +subroutine my_dt + + use m_openmpi + use m_parameters + implicit none + + integer :: n + real*8 :: courant_max=0.1 + + if (flow_type.le.1) then + + ! Courant number is calculated every iteration in rhsv.f + + if (courant.lt.courant_max) then + DT = DT * 1.01d0 + DT = min(DT,0.01) + else + DT = DT/1.05d0 + end if + +!---------------------------------------------------------------------- +! make sure DT is appropriate for scalars +! DT < 0.09 * dx^2*Pe +!---------------------------------------------------------------------- + if (int_scalars) then + do n=1,n_scalars +!!$ DT = min(DT,0.09*dx**2/PE(n)) + DT = min(DT,DT*courant_max/courant/sc(n)) + end do + end if + end if + + return +end subroutine my_dt diff --git a/my_exit.f90 b/my_exit.f90 new file mode 100644 index 0000000..af57464 --- /dev/null +++ b/my_exit.f90 @@ -0,0 +1,123 @@ +!================================================================================ +! MY_EXT - de-initializes everything, called at the end the main program +! or whenever we need to stop the program anywhere +! +! reason - the passed variable that describes the particular reason why +! we want to stop the program. +!================================================================================ +subroutine my_exit(reason) + + use m_openmpi + use m_io + use m_fields + use m_work +! use x_fftw + use m_particles + + implicit none + integer :: reason + + + write(out,"('my_exit with reason ',i4)") reason + + select case (reason) + + case(0) + + write(out,*) '---------------------------------------------' + write(out,*) ' NORMAL TERMIATION' + write(out,*) '---------------------------------------------' + + case(1) + + write(out,*) '---------------------------------------------' + write(out,*) ' TIME TERMINATION' + write(out,*) '---------------------------------------------' + call flush(out) + + case(2) + + write(out,*) '---------------------------------------------' + write(out,*) ' RUN-TIME TERMINATION' + write(out,*) '---------------------------------------------' + + case(3) + + write(out,*) '---------------------------------------------' + write(out,*) ' USER TERMINATION' + write(out,*) '---------------------------------------------' + + case default + + write(out,*) '---------------------------------------------' + write(out,*) ' TERMINATION FOR NO APPARENT REASON' + write(out,*) '---------------------------------------------' + + end select + + + if (reason.ge.0) then + if (task.eq.'hydro') call restart_write_parallel + if (task.eq.'parts') call particles_restart_write_binary + end if + + + write(out,*) "Done." + call flush(out) + close(out) + stop + + +! call m_fields_exit +! call m_work_exit +! call x_fftw_allocate(-1) +! call m_io_exit +! call m_openmpi_exit + + + return +end subroutine my_exit + +!!$!================================================================================ +!!$! MY_INIT - initializes everything, called at the beginning of the main program +!!$!================================================================================ +!!$subroutine my_init +!!$ +!!$! --- modules used +!!$ use m_openmpi +!!$ use m_io +!!$ use m_parameters +!!$ use m_fields +!!$ use m_work +!!$ use x_fftw +!!$ use m_filter_xfftw +!!$ implicit none +!!$ integer :: iargc +!!$ +!!$! --- initializing +!!$ call openmpi_init +!!$ call io_init +!!$ call parameters_init +!!$ call fields_init +!!$ call work_init(15) +!!$ call x_fftw_allocate(1) +!!$ call x_fftw_init +!!$ +!!$! --- getting the filter size +!!$ if(iargc().eq.0) then +!!$ call getarg(0,tmp_str) +!!$ write(out,*) 'Format: ',trim(tmp_str),' ' +!!$ write(*,*) 'Format: ',trim(tmp_str),' ' +!!$ call my_exit(-1) +!!$ end if +!!$ +!!$ ftype = 2 +!!$ call getarg(1,txt7) +!!$ read(txt7,*) filter_size +!!$ write(out,*) 'Filter size = ',filter_size +!!$ call flush(out) +!!$ +!!$ call filter_xfftw_init +!!$ +!!$return +!!$end subroutine my_init diff --git a/pressure.f90 b/pressure.f90 new file mode 100644 index 0000000..4298cb6 --- /dev/null +++ b/pressure.f90 @@ -0,0 +1,96 @@ +subroutine pressure + + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: i, j, k, n + real*8 :: div1, div2, lapl1, lapl2, p1, p2 + + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! getting the divergence (i*k*\hat(u)) + ! remember that in the Fourier space indicies go as (ix,iz,iy) + + ! getting divergence + div2 = akx(i )*fields(i ,j,k,1) + aky(k)*fields(i ,j,k,2) + akz(j)*fields(i ,j,k,3) + div1 = - ( akx(i+1)*fields(i+1,j,k,1) + aky(k)*fields(i+1,j,k,2) + akz(j)*fields(i+1,j,k,3) ) + + ! inverce laplace operator + lapl1 = akx(i )**2 + aky(k)**2 + akz(j)**2 + lapl2 = akx(i+1)**2 + aky(k)**2 + akz(j)**2 + + if (lapl1.eq.0.d0) lapl1 = 9e20 + if (lapl2.eq.0.d0) lapl2 = 9e20 + + ! calculating pressure + p1 = - div1 / lapl1 + p2 = - div2 / lapl2 + + ! Taking derivatives of the pressure and subtracting from the corresponding velocities + fields(i ,j,k,1) = fields(i ,j,k,1) + p2 * akx(i+1) + fields(i+1,j,k,1) = fields(i+1,j,k,1) - p1 * akx(i ) + + fields(i ,j,k,2) = fields(i ,j,k,2) + p2 * aky(k) + fields(i+1,j,k,2) = fields(i+1,j,k,2) - p1 * aky(k) + + fields(i ,j,k,3) = fields(i ,j,k,3) + p2 * akz(j) + fields(i+1,j,k,3) = fields(i+1,j,k,3) - p1 * akz(j) + + end do + end do + end do + + + return +end subroutine pressure + + + +subroutine divergence + + use m_openmpi + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: i,j,k + real*8 :: dmin, dmax, d1 + + + wrk(:,:,:,1:3) = fields(:,:,:,1:3) + + call x_derivative(1,'x',4) + call x_derivative(2,'y',5) + call x_derivative(3,'z',6) + + call xFFT3d(-1,4) + call xFFT3d(-1,5) + call xFFT3d(-1,6) + + wrk(:,:,:,0) = wrk(:,:,:,4) + wrk(:,:,:,5) + wrk(:,:,:,6) + + d1 = minval(wrk(1:nx,:,:,0)) + call MPI_REDUCE(d1,dmin,1,MPI_REAL8,MPI_MIN,0,MPI_COMM_TASK,mpi_err) + d1 = maxval(wrk(1:nx,:,:,0)) + call MPI_REDUCE(d1,dmax,1,MPI_REAL8,MPI_MAX,0,MPI_COMM_TASK,mpi_err) + + if (myid.eq.0) then + write(out,*) 'divergence:',dmin,dmax +!!$ print *, 'divergence:',dmin,dmax + call flush(out) + end if + + return +end subroutine divergence + + + diff --git a/restart_io.f90 b/restart_io.f90 new file mode 100644 index 0000000..5e6bc76 --- /dev/null +++ b/restart_io.f90 @@ -0,0 +1,506 @@ +!!$!================================================================================ +!!$!================================================================================ +!!$!================================================================================ +!!$subroutine restart_read +!!$ +!!$ use m_openmpi +!!$ use m_parameters +!!$ use m_io +!!$ use m_fields +!!$ use m_work +!!$ use x_fftw +!!$ use m_particles +!!$ implicit none +!!$ +!!$ integer*4 :: nx1,ny1,nz1, nums1, MST1, nums_read +!!$ integer :: i, j, k, n +!!$ +!!$ real*8 :: ST +!!$ +!!$ fname = run_name//'.64.'//file_ext +!!$ inquire(file=fname,exist=there) +!!$ if(.not.there) then +!!$ write(out,*) '*** error: Cannot find file : '//trim(fname) +!!$ stop +!!$ end if +!!$ +!!$ write(out,*) 'Reading from the file (seq): ',trim(fname) +!!$ call flush(out) +!!$ +!!$ ! root process reads parameters from the file +!!$ if (myid_world.eq.0) then +!!$ open(91,file=fname,form='unformatted',access='stream') +!!$ read(91) nx1, ny1, nz1, nums1, MST1, TIME, DT +!!$ end if +!!$ +!!$ call MPI_BCAST(nx1, 1,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) +!!$ call MPI_BCAST(ny1, 1,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) +!!$ call MPI_BCAST(nz1, 1,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) +!!$ call MPI_BCAST(nums1,1,MPI_INTEGER4,0,MPI_COMM_WORLD,mpi_err) +!!$ +!!$ call MPI_BCAST(TIME,1,MPI_REAL8,0,MPI_COMM_WORLD,mpi_err) +!!$ call MPI_BCAST( DT,1,MPI_REAL8,0,MPI_COMM_WORLD,mpi_err) +!!$ +!!$ ! everyone checks of the parameters coinside with what's in the .in file +!!$ if (nx.ne.nx1 .or. ny.ne.ny1 .or. nz_all.ne.nz1) then +!!$ write(out,*) '*** error: Dimensions are different' +!!$ write(out,*) '*** .in file: ',nx,ny,nz_all +!!$ write(out,*) '*** restart file: ',nx1,ny1,nz1 +!!$ call flush(out) +!!$ stop +!!$ end if +!!$ +!!$!----------------------------------------------------------------------- +!!$! dealing with scalars. +!!$! +!!$! The number of scalars can be varied throughout the simulation. +!!$! If the restart file has fewer scalars than the +!!$! .in file, the scalars are added and initialized according to +!!$! their description in the .in-file. +!!$! If the restart file has more scalars than the .in file, the +!!$! extra scalars are dropped. +!!$! +!!$! in short, whatever is specfied in the .in file, prevails. +!!$!----------------------------------------------------------------------- +!!$ +!!$ if (n_scalars.lt.nums1) then +!!$ +!!$ write(out,*) ' WARNING: nums in restart file:',nums1 +!!$ write(out,*) ' nums in .in file :',n_scalars +!!$ write(out,'(''Losing '',i3,'' scalars.'')') nums1-n_scalars +!!$ call flush(out) +!!$ nums_read = n_scalars +!!$ +!!$ else if (n_scalars.gt.nums1) then +!!$ +!!$ write(out,*) ' WARNING: nums in restart file:',nums1 +!!$ write(out,*) ' nums in .in file :',n_scalars +!!$ write(out,'(''Adding '',i3,'' scalars.'')') n_scalars-nums1 +!!$ call flush(out) +!!$ nums_read = nums1 +!!$ +!!$ +!!$ else +!!$ +!!$ nums_read = n_scalars +!!$ +!!$ end if +!!$ +!!$!---------------------------------------------------------------------- +!!$! ------------ reading the stuff from the restart file --------------- +!!$!---------------------------------------------------------------------- +!!$ +!!$ ! only the hydro part of processors is involved in this +!!$ hydro_only: if (task.eq.'hydro') then +!!$ count = (nx+2) * ny * nz +!!$ ! the root reads everything and sends to the slaves +!!$ if (myid.eq.0) then +!!$ do n = 1, 3 + nums_read + n_les +!!$ ! first chunk belongs to the root +!!$ read(91) (((fields(i,j,k,n),i=1,nx),j=1,ny),k=1,nz) +!!$ ! the rest gets read and sent to the appropriate porcess +!!$ do id_to = 1,numprocs-1 +!!$ read(91) (((wrk(i,j,k,1),i=1,nx),j=1,ny),k=1,nz) +!!$ tag = (3+nums_read) * id_to + n-1 +!!$ call MPI_SEND(wrk(1,1,1,1),count,MPI_REAL8,id_to,tag,MPI_COMM_TASK,mpi_err) +!!$ +!!$ +!!$ end do +!!$ end do +!!$ ! then the root closes the restart file +!!$ close(91) +!!$ else +!!$ ! the slaves receive and put it into ss array +!!$ do n = 1, 3 + nums_read + n_les +!!$ tag = (3+nums_read) * myid + n-1 +!!$ call MPI_RECV(fields(1,1,1,n),count,MPI_REAL8,0,tag,MPI_COMM_TASK,mpi_status,mpi_err) +!!$ end do +!!$ end if +!!$ +!!$ end if hydro_only +!!$ +!!$ return +!!$end subroutine restart_read +!!$ +!!$ +!!$ +!!$ +!!$!================================================================================ +!!$!================================================================================ +!!$!================================================================================ +!!$subroutine restart_write +!!$ +!!$! This routine is called to GENERATE RESTART FILES +!!$! The file is written without MPI-2 tricks +!!$! the stuff gets sent to the root process adn written out in +!!$! some orderly fashion +!!$ +!!$ use m_openmpi +!!$ use m_parameters +!!$ use m_io +!!$ use m_fields +!!$ use m_work +!!$ use x_fftw +!!$ implicit none +!!$ +!!$ integer :: n, nums_out, i, j, k +!!$ +!!$ real*8 :: ST +!!$ integer :: MST +!!$ +!!$ if (itime.eq.last_dump) return +!!$ +!!$ +!!$!--------------------------------------------------------------------- +!!$! dumping the restart file with particles +!!$!--------------------------------------------------------------------- +!!$! if (int_particles) call particles_restart_write +!!$! if (int_particles) call particles_restart_write_binary +!!$ +!!$ ! how many scalars to write +!!$ nums_out = 0 +!!$ if (int_scalars) nums_out = n_scalars +!!$ +!!$ ! first FFT everything to real space +!!$ wrk(:,:,:,1:3+nums_out+n_les) = fields(:,:,:,1:3+nums_out+n_les) +!!$ +!!$ ! --------------- writing process ------------------ +!!$ +!!$ fname = run_name//'.64.'//file_ext +!!$ +!!$ ! if not the root, just send the stuff to the root +!!$ if (myid.ne.0) then +!!$ +!!$ do n = 1 , 3 + nums_out + n_les +!!$ +!!$ wrk(:,:,:,0) = wrk(:,:,:,n) +!!$ tag = (3+nums_out+n_les) * myid + n-1 +!!$ count = (nx+2) * ny * nz +!!$ call MPI_ISEND(wrk(1,1,1,0),count,MPI_REAL8,0,tag,MPI_COMM_TASK,request,mpi_err) +!!$ +!!$! write(out,'(''sending var '',i3,'' to '',i4,'': '',i3)') n,0,mpi_err +!!$! call flush(out) +!!$ +!!$ call MPI_WAIT(request,mpi_status,mpi_err) +!!$ +!!$! write(out,'(''sent var '',i3,'' to '',i4,'': '',i3)') n,0,mpi_err +!!$! call flush(out) +!!$ +!!$ end do +!!$ +!!$ else +!!$ ! if it's the root, then write the restart file +!!$!! open(91,file=fname,form='binary') +!!$ open(91,file=fname,form='unformatted', access='stream') +!!$ +!!$ ! first write the parameters +!!$ ST = zip +!!$ write(91) int(nx,4),int(ny,4),int(nz*numprocs,4),int(nums_out,4),int(MST,4),TIME,DT +!!$ +!!$ ! then write the variables, one by one +!!$ do n = 1 , 3 + nums_out + n_les +!!$ +!!$ ! first write the chunk from the root process +!!$ wrk(:,:,:,0) = wrk(:,:,:,n) +!!$ write(91) (((wrk(i,j,k,0),i=1,nx),j=1,ny),k=1,nz) +!!$ ! then receive chinks of the same variable from each process and write it out +!!$ do id_from=1,numprocs-1 +!!$ tag = (3+nums_out+n_les) * id_from + n-1 +!!$ count = (nx+2) * ny * nz +!!$ call MPI_RECV(wrk(1,1,1,0),count,MPI_REAL8,id_from,tag,MPI_COMM_TASK,mpi_status,mpi_err) +!!$ +!!$! write(out,'(''received var '',i3,'' from '',i4,'': '',i3)') n,id_from,mpi_err +!!$! call flush(out) +!!$ +!!$ write(91) (((wrk(i,j,k,0),i=1,nx),j=1,ny),k=1,nz) +!!$ end do +!!$ end do +!!$ close(91) +!!$ +!!$ end if +!!$ +!!$ write(out,*) '------------------------------------------------' +!!$ write(out,*) 'Restart file written (seq): '//trim(fname) +!!$ write(out,"(' Velocities and ',i3,' scalars (incl. LES)')") nums_out+n_les +!!$ write(out,"(' Restart file time = ',f15.10,i7)") time,itime +!!$ write(out,*) '------------------------------------------------' +!!$ call flush(out) +!!$ +!!$ +!!$ ! setting the variable last_dump to current timestep number +!!$ last_dump = ITIME +!!$ +!!$ return +!!$end subroutine restart_write +!!$ +!!$ +!================================================================================ +!================================================================================ +!================================================================================ +subroutine restart_write_parallel + +! This routine is called to GENERATE RESTART FILES +! The file is written using the collective write (MPI-2 standard) + + use m_openmpi + use m_parameters + use m_io + use m_fields + use m_work + use x_fftw + implicit none + + integer :: n, nums_out, i, j, k + + integer :: MST + integer(kind=MPI_INTEGER_KIND) :: fh + integer(kind=MPI_OFFSET_KIND) :: offset + real*8, allocatable :: sctmp8(:,:,:) + + integer*4 :: nx1, ny1, nz1, nums1, nles1 + real*8 :: ST + + if (itime.eq.last_dump) return + + ! how many scalars to write + nums_out = 0 + if (int_scalars) nums_out = n_scalars + + ! using wrk array + wrk(:,:,:,1:3+nums_out) = fields(:,:,:,1:3+nums_out) + if (n_les>0) wrk(:,:,:,3+nums_out+1:3+nums_out+n_les) = fields(:,:,:,3+n_scalars+1:3+n_scalars+n_les) + + ! --------------- writing process ------------------ + + fname = run_name//'.64.'//file_ext + + ! allocating the temporary array sctmp8 + allocate(sctmp8(nx,ny,nz),stat=ierr) + if (ierr.ne.0) stop '*** RESTART_READ_PARALLEL: cannot allocate sctmp8' + sctmp8 = zip + + ! opening the file + call MPI_INFO_CREATE(mpi_info, mpi_err) + call MPI_FILE_OPEN(MPI_COMM_TASK,fname,MPI_MODE_WRONLY+MPI_MODE_CREATE,mpi_info,fh,mpi_err) + + ! the master node writes the header with parameters + if (myid.eq.0) then + nx1 = nx; ny1 = ny; nz1 = nz_all; nles1 = n_les; nums1 = nums_out; + count = 1 + ST = zip + call MPI_FILE_WRITE(fh, nx1, count, MPI_INTEGER4, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, ny1, count, MPI_INTEGER4, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, nz1, count, MPI_INTEGER4, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, nums1, count, MPI_INTEGER4, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, nles1, count, MPI_INTEGER4, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, TIME, count, MPI_REAL8, mpi_status, mpi_err) + call MPI_FILE_WRITE(fh, DT, count, MPI_REAL8, mpi_status, mpi_err) + end if + + ! all nodes write their stuff into the file + ! first writing the velocities and passive scalars + writing_fields: do n = 1, 3 + nums_out + n_les + + offset = 36 + (n-1)*nx*ny*nz_all*8 + myid*nx*ny*nz*8 + count = nx * ny * nz + ! note that we want the data from the restart to have dimensions (nx,ny,nz), + ! while the fields array has fimensions (nx+2,ny,nz). + ! this is an artefact of the times when the code used to write the variables in real space. + ! that is why we need to duplicate each field in the sctmp array first, and then + ! write sctmp8 into the file with appropriate offset + + sctmp8(1:nx,1:ny,1:nz) = wrk(1:nx,1:ny,1:nz,n) + + call MPI_FILE_WRITE_AT(fh, offset, sctmp8, count, MPI_REAL8, mpi_status, mpi_err) + + end do writing_fields + + + call MPI_FILE_CLOSE(fh, mpi_err) + call MPI_INFO_FREE(mpi_info, mpi_err) + deallocate(sctmp8) + + write(out,*) '------------------------------------------------' + write(out,*) 'Restart file written (par): '//trim(fname) + write(out,"(' Velocities and ',i3,' passive scalars')") nums_out + if (n_les>0) write(out,"(' Also wrote',i3,' LES scalars)')") n_les + write(out,"(' Restart file time = ',f15.10,i7)") time, itime + write(out,*) '------------------------------------------------' + call flush(out) + + last_dump = ITIME + + return +end subroutine restart_write_parallel + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ + +subroutine restart_read_parallel + + use m_openmpi + use m_parameters + use m_io + use m_fields + use m_work + use x_fftw + use m_particles + implicit none + + integer*4 :: nx1,ny1,nz1, nums1, nles1, nums_read + integer :: i, j, k, n, n_skip + + integer(kind=MPI_INTEGER_KIND) :: fh + integer(kind=MPI_OFFSET_KIND) :: offset + real*8, allocatable :: sctmp8(:,:,:) + + ! checking if the restart file exists + fname = run_name//'.64.'//file_ext + inquire(file=fname,exist=there) + if(.not.there) then + write(out,*) '*** error: Cannot find file : '//trim(fname) + stop + end if + + write(out,*) 'Reading from the file (par): ',trim(fname) + call flush(out) + + ! ---------------------------------------------------------------------- + ! first reading the parameters from the restart file. + ! the root process opens it and reads the parameters, then broadcasts + ! the parameters. After that it's decided if the parameters make sense, + ! how many scalars to read etc. + ! ---------------------------------------------------------------------- + + if (myid.eq.0) then + open(91,file=fname,form='unformatted',access='stream') + read(91) nx1, ny1, nz1, nums1, nles1, TIME, DT + close(91) + end if + + call MPI_BCAST(nx1, 1,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(ny1, 1,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(nz1, 1,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(nums1,1,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST(nles1,1,MPI_INTEGER4,0,MPI_COMM_TASK,mpi_err) + + call MPI_BCAST(TIME,1,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + call MPI_BCAST( DT,1,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + + ! checking if the array sizes are the same in .in file and restart file + if (nx.ne.nx1 .or. ny.ne.ny1 .or. nz_all.ne.nz1) then + write(out,*) '*** error: Dimensions are different' + write(out,*) '*** .in file: ',nx,ny,nz_all + write(out,*) '*** restart file: ',nx1,ny1,nz1 + call flush(out) + call my_exit(-1) + end if + + ! checking if the number of LES quantities is the same in .in and restart files + if (n_les .ne. nles1) then + write(out,*) '*** WARNING : Different values of n_les:' + write(out,*) '*** .in file: ',n_les + write(out,*) '*** restart file: ',nles1 + write(out,*) '*** Make sure you are running the same simulation.' + call flush(out) + end if + +!----------------------------------------------------------------------- +! dealing with scalars. +! +! The number of scalars can be varied throughout the simulation. +! If the restart file has fewer scalars than the +! .in file, the scalars are added and initialized according to +! their description in the .in-file. +! If the restart file has more scalars than the .in file, the +! extra scalars are dropped. +! +! in short, whatever is specfied in the .in file, prevails. +!----------------------------------------------------------------------- + + if (n_scalars.lt.nums1) then + + write(out,*) ' WARNING: nums in restart file:',nums1 + write(out,*) ' nums in .in file :',n_scalars + write(out,'(''Losing '',i3,'' scalars.'')') nums1-n_scalars + call flush(out) + nums_read = n_scalars + + else if (n_scalars.gt.nums1) then + + write(out,*) ' WARNING: nums in restart file:',nums1 + write(out,*) ' nums in .in file :',n_scalars + write(out,'(''Adding '',i3,'' scalars.'')') n_scalars-nums1 + call flush(out) + nums_read = nums1 + + ! initializing the added scalars + do n=nums1+1,n_scalars + call init_scalar(n) + end do + + else + + nums_read = n_scalars + + end if + +!---------------------------------------------------------------------- +! ------------ reading the stuff from the restart file --------------- +!---------------------------------------------------------------------- + + ! allocating the temporary array sctmp8 + allocate(sctmp8(nx,ny,nz),stat=ierr) + if (ierr.ne.0) stop '*** RESTART_READ_PARALLEL: cannot allocate sctmp8' + sctmp8 = zip + + ! opening the file + call MPI_INFO_CREATE(mpi_info, mpi_err) + call MPI_FILE_OPEN(MPI_COMM_TASK,fname,MPI_MODE_RDONLY,mpi_info,fh,mpi_err) + + ! note that the data from the restart file has dimensions (nx,ny,nz), + ! while the fields array has fimensions (nx+2,ny,nz). + ! that is why we need to read each field in the sctmp array first, and then + ! rearrange it and put into the fields array. + + reading_fields: do n = 1, 3 + nums_read + + write(out,"('Reading variable # ',i3)") n + call flush(out) + + offset = 36 + (n-1)*nx*ny*nz_all*8 + myid*nx*ny*nz*8 + count = nx * ny * nz +! call MPI_FILE_READ_AT(fh, offset, sctmp8, count, MPI_REAL8, mpi_status, mpi_err) + call MPI_FILE_READ_AT_ALL(fh, offset, sctmp8, count, MPI_REAL8, mpi_status, mpi_err) + fields(1:nx,1:ny,1:nz,n) = sctmp8(1:nx,1:ny,1:nz) + end do reading_fields + + ! now reading the LES variables. They are stored after the fields + ! u,v,w,sc(1...nums1), so we are applying the offset based on the + ! number of scalars in the restart file. + reading_les_fields: do n = 1, n_les + + write(out,"('Reading LES variable # ',i3)") n + call flush(out) + + n_skip = 3 + nums1 + offset = 36 + (n_skip+n-1)*nx*ny*nz_all*8 + myid*nx*ny*nz*8 + + + count = nx * ny * nz +! call MPI_FILE_READ_AT(fh, offset, sctmp8, count, MPI_REAL8, mpi_status, mpi_err) + call MPI_FILE_READ_AT_ALL(fh, offset, sctmp8, count, MPI_REAL8, mpi_status, mpi_err) + fields(1:nx,1:ny,1:nz,3+n_scalars+n) = sctmp8(1:nx,1:ny,1:nz) + end do reading_les_fields + + call MPI_FILE_CLOSE(fh, mpi_err) + call MPI_INFO_FREE(mpi_info, mpi_err) + deallocate(sctmp8) + + write(out,*) "Restart file successfully read." + call flush(out) + + return +end subroutine restart_read_parallel diff --git a/rhs_scalars.f90 b/rhs_scalars.f90 new file mode 100644 index 0000000..72a7f87 --- /dev/null +++ b/rhs_scalars.f90 @@ -0,0 +1,594 @@ +subroutine rhs_scalars + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + use m_timing + use m_les + + implicit none + + integer :: i, j, k, n, n1, n2, nv, ns_lo, ns_hi + real*8 :: rtmp1, rtmp2, wnum2, r11, r12, r21, r22, r31, r32 + + ! calculate turbulent viscosity, if any + if (les) call les_get_turb_visc + + ! If we're not advancing scalars, put the real-space velocities + ! in wrk1...3 and return + ! same is done if dealias=0, that is, we use 2/3 rule. + ! if dealias=1 (phase shifts) then this is done later in the subroutine + + ! also if doing LES and n_les (the # of les-related auxilary scalars) is + ! greater than 0, then we need to transport these LES-related scalars, + ! even if n_scalars=0. + + ! thus we do the obligatory part (tranfer velocities to X-space) and quit + ! only when we are not transporting any scalars and if there are no + ! LES-related scalars. + if (.not.int_scalars .and. n_les .eq. 0) then + ! converting velocities to the real space and returning + wrk(:,:,:,1:3) = fields(:,:,:,1:3) + do n = 1,3 + call xFFT3d(-1,n) + end do + return + end if + + ! making the RHS for all scalars zero + wrk(:,:,:,4:3+n_scalars+n_les) = zip + +!-------------------------------------------------------------------------------- +! If dealias=0, performing the 2/3 rule dealiasing on scalars +!-------------------------------------------------------------------------------- + + if (dealias.eq.0) then + + ! converting velocities to the real space + wrk(:,:,:,1:3) = fields(:,:,:,1:3) + do n = 1,3 + call xFFT3d(-1,n) + end do + + ! Do each scalar one at a time. Keep the velocities in wrk1:3 intact + ! because they are needed later. + + ! first we need to know which scalars do we want to transport. + ! There are three cases: + ! (0) No LES extra scalars, and passive scalars have not been initialized yet + ! Thus this subroutine calculates the IFFT of velocities and exits. + ! This is taken care of earlier. + ! (1) Both passive scalars and LES extra scalars are transported + ! This is possible when n_les > 0 and int_scalars=.true. + ! (2) Only LES extra scalars are transported + ! This is possible if and only if (.not.int_scalars .and. n_les>0) + ! + ! The last two cases are taken care of by prescribing ns_lo and ns_hi, the + ! smallest and largest number of the scalar that needs to be transported. + + ns_lo = 1; + ns_hi = n_scalars + n_les + if (.not.int_scalars) ns_lo = n_scalars + 1 + + do n = ns_lo, ns_hi + + wrk(:,:,:,0) = fields(:,:,:,3+n) + call xFFT3d(-1,0) + + ! Products of the scalar and velocities + do i = 1,3 + wrk(:,:,:,n+2+i) = wrk(:,:,:,0) * wrk(:,:,:,i) + call xFFT3d(1,n+2+i) + end do + + ! Assembling the RHS in wrk(:,:,:,3+n) + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! If the dealiasing option is 2/3-rule (dealias=0) then we retain the modes + ! inside the cube described by $| k_i | \leq k_{max}$, $i=1,2,3$. + ! The rest of the modes is purged + + if (ialias(i,j,k) .gt. 0) then + ! all the wavenumbers that are greater than kmax get zeroed out + wrk(i ,j,k,3+n) = zip + wrk(i+1,j,k,3+n) = zip + + else + ! taking the convective term, multiply it by "i" + ! (see how it's done in x_fftw.f90) + ! and adding the diffusion term + + ! also using the fact that the waveunmbers for (i,j,k) are the same + ! as wavenumbers for (i+1,j,k) + + ! i * (a + ib) + d = -b + ia + d + rtmp1 = akx(i+1)*wrk(i+1,j,k,3+n) + aky(k)*wrk(i+1,j,k,4+n) + akz(j)*wrk(i+1,j,k,5+n) + rtmp2 = akx(i )*wrk(i ,j,k,3+n) + aky(k)*wrk(i ,j,k,4+n) + akz(j)*wrk(i ,j,k,5+n) + + wnum2 = akx(i)**2 + aky(k)**2 + akz(j)**2 + + wrk(i ,j,k,3+n) = rtmp1 - pe(n) * wnum2*fields(i ,j,k,3+n) + wrk(i+1,j,k,3+n) = - rtmp2 - pe(n) * wnum2*fields(i+1,j,k,3+n) + + end if + end do + end do + end do + + ! Now adding the reaction part (for scalars only, not for LES-related quantities + ! that are formally scalars with indicies n_scalars+1...n_scalars+n_les ) + if (n .le. n_scalars) then + if (scalar_type(n).ge.100) then + call add_reaction(n) + call dealias_rhs(3+n) + end if + end if + + end do + + end if + +!-------------------------------------------------------------------------------- +! If dealias=1, performing the phase shift and truncation on scalars +! The main ideology is as follows. First we evaluate the phase-shifted +! quantities, then not phase shifted. This is done in order to have more +! working space: at the beginning we have all work arrays available, but at the +! end we must put sin/cos factors in wrk0 and u.v.w in real space in wrk1...3. +! They are going to be used again in rhs_velocity later. +!-------------------------------------------------------------------------------- + phase_shifting_dealiasing: if (dealias.eq.1) then + + ! define the sin/cos factors that are used in phase shifting. + ! computing sines and cosines for the phase shift of dx/2,dy/2,dz/2 + ! and putting them into wrk0 + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + wrk(i ,j,k,0) = cos(half*(akx(i )+aky(k)+akz(j))*dx) + wrk(i+1,j,k,0) = sin(half*(akx(i+1)+aky(k)+akz(j))*dx) + end do + end do + end do + + ! Doing all scalars at the same time. We can do this because the + ! number of work arrays that are available to us is 3+n+2. First + ! three later will be taken by velocities, and the last two are + ! primary work arrays here. + + ! First, get phase shifted velocities and scalars + do n = 1, 3 + n_scalars + n_les + ! phase-shifting the quantity + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + wrk(i ,j,k,n) = fields(i ,j,k,n) * wrk(i,j,k,0) - fields(i+1,j,k,n) * wrk(i+1,j,k,0) + wrk(i+1,j,k,n) = fields(i+1,j,k,n) * wrk(i,j,k,0) + fields(i ,j,k,n) * wrk(i+1,j,k,0) + end do + end do + end do + ! transforming it to real space + call xFFT3d(-1,n) + end do + + ! now we have two vacant arrays: n_scalars+n_les+4 and n_scalars+n_les+5. Work in them + n1 = n_scalars + n_les + 4 + n2 = n_scalars + n_les + 5 + + ! do one scalar at a time + phase_shifted_rhs: do n = 4, 3 + n_scalars + n_les + + ! getting all three products of phase-shifted scalar and phase-shifted velocities + ! using three work arrays: n, n1 and n2 + wrk(:,:,:,n1) = wrk(:,:,:,n) * wrk(:,:,:,1) + wrk(:,:,:,n2) = wrk(:,:,:,n) * wrk(:,:,:,2) + wrk(:,:,:,n ) = wrk(:,:,:,n) * wrk(:,:,:,3) + ! transforming them to Fourier space + call xFFT3d(1,n1) + call xFFT3d(1,n2) + call xFFT3d(1,n ) + + ! phase shifting them back using wrk0 and adding -0.5*(ik) to the RHS for the scalar + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + if (ialias(i,j,k) .gt. 1) then + wrk(i:i+1,j,k,n) = zip + else + ! (u+)*(phi+) phase shifted back + r11 = wrk(i ,j,k,n1) * wrk(i,j,k,0) + wrk(i+1,j,k,n1) * wrk(i+1,j,k,0) + r12 = wrk(i+1,j,k,n1) * wrk(i,j,k,0) - wrk(i ,j,k,n1) * wrk(i+1,j,k,0) + ! (v+)*(phi+) phase shifted back + r21 = wrk(i ,j,k,n2) * wrk(i,j,k,0) + wrk(i+1,j,k,n2) * wrk(i+1,j,k,0) + r22 = wrk(i+1,j,k,n2) * wrk(i,j,k,0) - wrk(i ,j,k,n2) * wrk(i+1,j,k,0) + ! (w+)*(phi+) phase shifted back + r31 = wrk(i ,j,k,n ) * wrk(i,j,k,0) + wrk(i+1,j,k,n ) * wrk(i+1,j,k,0) + r32 = wrk(i+1,j,k,n ) * wrk(i,j,k,0) - wrk(i ,j,k,n ) * wrk(i+1,j,k,0) + ! adding -0.5*(ik)*(the result) to the RHSs for the scalar + wrk(i ,j,k,n) = + 0.5d0 * ( akx(i+1)*r12 + aky(k)*r22 + akz(j)*r32 ) + wrk(i+1,j,k,n) = - 0.5d0 * ( akx(i )*r11 + aky(k)*r21 + akz(j)*r31 ) + end if + + end do + end do + end do + + end do phase_shifted_rhs + + ! at this moment wrk4...3+n_scalars+n_les contain the half of the convective term, which was + ! obtained from the phase shifted quantities. Now we need to add the other half of the + ! convective term (the one that is obtained by multiplication of no-phase-shifted stuff) + + ! first get the velocities into the real space and put them in wrk1...3 + ! this should remain in there untouched, to be used in rhs_velocity later + do n = 1,3 + wrk(:,:,:,n) = fields(:,:,:,n) + call xFFT3d(-1,n) + end do + + ! now do scalars one at a time since we don't have enough storage to do them + ! all at once + + not_phase_shifted_rhs: do n = 4, 3 + n_scalars + n_les + + ! get the scalar into the real space and put it in the wrk(0) + wrk(:,:,:,0) = fields(:,:,:,n) + call xFFT3d(-1,0) + + ! calculate the product of the scalar with velocitiy components + wrk(:,:,:,n1) = wrk(:,:,:,0) * wrk(:,:,:,1) + wrk(:,:,:,n2) = wrk(:,:,:,0) * wrk(:,:,:,2) + wrk(:,:,:, 0) = wrk(:,:,:,0) * wrk(:,:,:,3) + ! transform it to the Fourier space + call xFFT3d(1,n1) + call xFFT3d(1,n2) + call xFFT3d(1, 0) + + ! add the -0.5*(ik)*results to the RHS, along with the diffusion term + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + if (ialias(i,j,k) .lt. 2) then + + rtmp1 = akx(i+1)*wrk(i+1,j,k,n1) + aky(k)*wrk(i+1,j,k,n2) + akz(j)*wrk(i+1,j,k,0) + rtmp2 = akx(i )*wrk(i ,j,k,n1) + aky(k)*wrk(i ,j,k,n2) + akz(j)*wrk(i ,j,k,0) + + wnum2 = akx(i)**2 + aky(k)**2 + akz(j)**2 + wrk(i ,j,k,n) = wrk(i ,j,k,n) + 0.5d0 * rtmp1 - pe(n-3) * wnum2*fields(i ,j,k,n) + wrk(i+1,j,k,n) = wrk(i+1,j,k,n) - 0.5d0 * rtmp2 - pe(n-3) * wnum2*fields(i+1,j,k,n) + + end if + end do + end do + end do + + end do not_phase_shifted_rhs + + ! ------------------------------------------------------------ + ! Add the reaction rates to the RHS + ! + ! The LES-related scalars are not affected because the + ! upper bound for n is 3+n_scalars, not 3+n_scalars+n_les + ! ----------------------------------------------------------- + + reaction_rates: do n = 4, 3+n_scalars + + if (scalar_type(n-3) .gt. 300) then + +!!$ ! putting phase shifted scalar in wrk(n1) +!!$ do k = 1,nz +!!$ do j = 1,ny +!!$ do i = 1,nx+1,2 +!!$ wrk(i ,j,k,n1) = fields(i ,j,k,n) * wrk(i,j,k,0) - fields(i+1,j,k,n) * wrk(i+1,j,k,0) +!!$ wrk(i+1,j,k,n1) = fields(i+1,j,k,n) * wrk(i,j,k,0) + fields(i ,j,k,n) * wrk(i+1,j,k,0) +!!$ end do +!!$ end do +!!$ end do +!!$ ! transforming it to real space +!!$ call xFFT3d(-1,n1) +!!$ ! putting the phase-shifted reaction rate in wrk(n2) +!!$ call scalar_reaction_rate(n1,n2) +!!$ ! transforming to Fourier space +!!$ call xFFT3d(1,n2) +!!$ ! phase shifting back and adding a half of it to the RHS +!!$ do k = 1,nz +!!$ do j = 1,ny +!!$ do i = 1,nx+1,2 +!!$ if (ialias(i,j,k) .le. 1) then +!!$ ! phase shifting back +!!$ r11 = wrk(i ,j,k,n2) * wrk(i,j,k,0) + wrk(i+1,j,k,n2) * wrk(i+1,j,k,0) +!!$ r12 = wrk(i+1,j,k,n2) * wrk(i,j,k,0) - wrk(i ,j,k,n2) * wrk(i+1,j,k,0) +!!$ ! adding 0.5*(the result) to the RHSs for the scalar +!!$ wrk(i ,j,k,n) = wrk(i ,j,k,n) + 0.5d0 * r11 +!!$ wrk(i+1,j,k,n) = wrk(i+1,j,k,n) + 0.5d0 * r12 +!!$ end if +!!$ end do +!!$ end do +!!$ end do +!!$ +!!$ ! scond part: doing the same thing with not-phase-shifted scalar +!!$ ! putting it in wrk(n1) +!!$ wrk(:,:,:,n1) = fields(:,:,:,n) +!!$ ! transforming it to real space +!!$ call xFFT3d(-1,n1) +!!$ ! putting the phase-shifted reaction rate in wrk(n2) +!!$ call scalar_reaction_rate(n1,n2) +!!$ ! transforming to Fourier space +!!$ call xFFT3d(1,n2) +!!$ ! phase shifting back and adding a half of it to the RHS +!!$ do k = 1,nz +!!$ do j = 1,ny +!!$ do i = 1,nx+1,2 +!!$ if (ialias(i,j,k) .le. 1) then +!!$ ! phase shifting back +!!$ r11 = wrk(i ,j,k,n2) * wrk(i,j,k,0) + wrk(i+1,j,k,n2) * wrk(i+1,j,k,0) +!!$ r12 = wrk(i+1,j,k,n2) * wrk(i,j,k,0) - wrk(i ,j,k,n2) * wrk(i+1,j,k,0) +!!$ ! adding 0.5*(the result) to the RHSs for the scalar +!!$ wrk(i ,j,k,n) = wrk(i ,j,k,n) + 0.5d0 * r11 +!!$ wrk(i+1,j,k,n) = wrk(i+1,j,k,n) + 0.5d0 * r12 +!!$ end if +!!$ end do +!!$ end do +!!$ end do + + if (scalar_type(n-3) .eq. 311) then + + ! since the reaction rate is cubic, we need to apply some severe truncation. + + ! putting the scalar in wrk(n1) + wrk(:,:,:,n1) = fields(:,:,:,n) + ! truncating it so only the modes with |k_i| < nx/4 remain + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + if (abs(akx(i)).gt.nx/4 .or. abs(aky(k)).gt.nx/4 .or. abs(akz(j)).gt.nx/4) then + wrk(i ,j,k,n1) = zip + wrk(i+1,j,k,n1) = zip + end if + end do + end do + end do + + ! transforming it to real space + call xFFT3d(-1,n1) + + ! self-adjusting bistable reaction needs the mean value of the scalar + rtmp1 = fields(1,1,1,n)/nxyz_all + call MPI_BCAST(rtmp1, 1, MPI_REAL8, 0, MPI_COMM_TASK, mpi_err) + + ! getting the reaction rate + wrk(:,:,:,n2) = reac_sc(n-3) * (one - wrk(:,:,:,n1)**2) * (wrk(:,:,:,n1) - rtmp1) + + ! transforming it to Fourier space + call xFFT3d(1,n2) + + ! adding to the RHS + wrk(:,:,:,n) = wrk(:,:,:,n) + wrk(:,:,:,n2) + + else + write(out,*) "The scalar type has a reaction rate that is not supported yet:", scalar_type(n-3) + call flush(out) + call my_exit(-1) + end if + end if + end do reaction_rates + + end if phase_shifting_dealiasing + + ! special case - passive scalar with the uniform gradient as a source + ! adding the source term - the first component of velocity, because we assume + ! that the uniform gradient has slope 1 and direction in the x-direction + gradient_source: do n = 1, n_scalars + if (scalar_type(n) .eq. 0) wrk(:,:,:,n+3) = wrk(:,:,:,n+3) - fields(:,:,:,1) + end do gradient_source + + + +!-------------------------------------------------------------------------------- +! Add LES to the RHS of all the scalars +!-------------------------------------------------------------------------------- + les_active: if (les) then + call les_rhs_scalars + end if les_active + + + return +end subroutine rhs_scalars + +!================================================================================ +!================================================================================ +subroutine add_reaction(n) + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: n, rtype + real*8 :: scmean, rrate + + ! reaction type + rtype = scalar_type(n)/100 + + ! raction rate + rrate = reac_sc(n) + + select case (rtype) + case (1) + + ! KPP reaction rate + wrk(:,:,:,0) = rrate * (1.d0 - wrk(:,:,:,0)**2) + + case (2) + + ! symmetric bistable + wrk(:,:,:,0) = rrate * (1.d0 - wrk(:,:,:,0)**2) * wrk(:,:,:,0) + + case (3) + + ! self-adjusting bistable + scmean = fields(1,1,1,3+n)/nxyz_all + call MPI_BCAST(scmean, 1, MPI_REAL8, 0, MPI_COMM_TASK, mpi_err) + + wrk(:,:,:,0) = rrate * (1.d0 - wrk(:,:,:,0)**2) * & + (wrk(:,:,:,0) - scmean) + case default + + write(out,*) "Unknown reaction rate" + call flush(out) + + stop + + end select + + + ! FFT the reaction into the Fourier space + call xFFT3d(1,0) + + ! Adding reaction to the RHS in wrk(:,:,:,3+n) + + wrk(:,:,:,3+n) = wrk(:,:,:,3+n) + wrk(:,:,:,0) + +end subroutine add_reaction + +!================================================================================ + +subroutine dealias_rhs(n) + + use m_io + use m_parameters + use m_work + use x_fftw + + implicit none + + integer :: i, j, k, n + real*8 :: wnum2, akmax + + akmax = real(kmax,8) + + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + if ( abs(akx(i)).gt.akmax .or. & + abs(aky(k)).gt.akmax .or. & + abs(akz(j)).gt.akmax ) then + + wrk(i ,j,k,n) = zip + wrk(i+1,j,k,n) = zip + end if + + end do + end do + end do + + return + +end subroutine dealias_rhs + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +subroutine test_rhs_scalars + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: i,j,k, n + real*8 :: a,b,c, x,y,z + if (task.eq.'hydro') then + + a = 1.d0 + b = 5.d0 + c = 17.d0 + + do k = 1,nz + do j = 1,ny + do i = 1,nx + + x = dx*real(i-1) + y = dx*real(j-1) + z = dx*real(myid*nz + k-1) + + wrk(i,j,k,1) = sin(a * x) + wrk(i,j,k,2) = sin(b * y) + wrk(i,j,k,3) = sin(c * z) + wrk(i,j,k,4) = cos(a * x) + end do + end do + end do + + + do n = 1,4 + call xFFT3d(1,n) + fields(:,:,:,n) = wrk(:,:,:,n) + end do + + + nu = .5d0 + + call rhs_scalars + + print *,'got rhs' + + call xFFT3d(-1,4) + + + do k = 1,nz + do j = 1,ny + do i = 1,nx + + x = dx*real(i-1) + y = dx*real(j-1) + z = dx*real(myid*nz + k-1) + + + ! checking + wrk(i,j,k,0) = -a*cos(2.*a*x) - cos(a*x)*(b*cos(b*y) + c*cos(c*z) + nu*a**2) + + end do + end do + end do + +!!$ tmp4(:,:,:) = wrk(1:nx,:,:,4) +!!$ fname = 'r1.arr' +!!$ call write_tmp4 +!!$ +!!$ tmp4(:,:,:) = wrk(1:nx,:,:,0) +!!$ fname = 'r0.arr' +!!$ call write_tmp4 + + + + + wrk(:,:,:,0) = abs(wrk(1:nx,:,:,0) - wrk(1:nx,:,:,4)) + + print *,'Maximum error is ',maxval(wrk(1:nx,:,:,0)) + +!!$ tmp4(:,:,:) = wrk(1:nx,:,:,3) - wrk(1:nx,:,:,6) +!!$ fname = 'e3.arr' +!!$ call write_tmp4 +!!$ + + + end if + return +end subroutine test_rhs_scalars diff --git a/rhs_velocity.f90 b/rhs_velocity.f90 new file mode 100644 index 0000000..50fc974 --- /dev/null +++ b/rhs_velocity.f90 @@ -0,0 +1,553 @@ +subroutine rhs_velocity + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + use m_les + + implicit none + + integer :: i, j, k, n, nx3 + real*8 :: t1(0:6), rtmp, wnum2, rnx3 + + + + ! The IFFT of velocities has been done earlier in rhs_scalars + ! the velocities were kept in wrk1...wrk3, intact. + +!!$ ! putting the velocity field in the wrk array +!!$ wrk(:,:,:,1:3) = fields(:,:,:,1:3) +!!$ ! performing IFFT to convert them to the X-space +!!$ call xFFT3d(-1,1) +!!$ call xFFT3d(-1,2) +!!$ call xFFT3d(-1,3) + + +!------------------------------------------------------------------------- + ! getting the Courant number (on the master process only) + wrk(:,:,:,4) = abs(wrk(:,:,:,1)) + abs(wrk(:,:,:,2)) + abs(wrk(:,:,:,3)) + rtmp = maxval(wrk(1:nx,:,:,4)) + call MPI_REDUCE(rtmp,courant,1,MPI_REAL8,MPI_MAX,0,MPI_COMM_TASK,mpi_err) + if (variable_dt) then + count = 1 + call MPI_BCAST(courant,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + end if + courant = courant * dt / dx + +!------------------------------------------------------------------------- + +!-------------------------------------------------------------------------------- +! Calculating the right-hand side for the velocities +! +! There are two options available: the standard 2/3 rule (dealias=0) and +! combination of phase shift and truncation (dealias=1). The latter retains +! more modes but requires more calculations thus slowing down the simulation. +! These are treated separately in two different "if" blocks. This is done in +! order not to complicate the logic. Also this way both blocks can be +! optimized separately. +!-------------------------------------------------------------------------------- + + two_thirds_rule: if (dealias.eq.0) then + + ! getting all 6 products of velocities + do k = 1,nz + do j = 1,ny + do i = 1,nx + t1(1) = wrk(i,j,k,1) * wrk(i,j,k,1) + t1(2) = wrk(i,j,k,1) * wrk(i,j,k,2) + t1(3) = wrk(i,j,k,1) * wrk(i,j,k,3) + t1(4) = wrk(i,j,k,2) * wrk(i,j,k,2) + t1(5) = wrk(i,j,k,2) * wrk(i,j,k,3) + t1(6) = wrk(i,j,k,3) * wrk(i,j,k,3) + + do n = 1,6 + wrk(i,j,k,n) = t1(n) + end do + + end do + end do + end do + + + ! converting the products to the Fourier space + do n = 1,6 + call xFFT3d(1,n) + end do + + ! Building the RHS. + ! First, put into wrk arrays the convectove terms (that will be multiplyed by "i" + ! later) and the factor that corresponds to the diffusion + + ! Do not forget that in Fourier space the indicies are (ix, iz, iy) + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + + t1(1) = - ( akx(i) * wrk(i,j,k,1) + aky(k) * wrk(i,j,k,2) + akz(j) * wrk(i,j,k,3) ) + t1(2) = - ( akx(i) * wrk(i,j,k,2) + aky(k) * wrk(i,j,k,4) + akz(j) * wrk(i,j,k,5) ) + t1(3) = - ( akx(i) * wrk(i,j,k,3) + aky(k) * wrk(i,j,k,5) + akz(j) * wrk(i,j,k,6) ) + + + t1(4) = - nu * ( akx(i)**2 + aky(k)**2 + akz(j)**2 ) + + do n = 1,4 + wrk(i,j,k,n) = t1(n) + end do + + end do + end do + end do + + ! now take the actual fields from fields(:,:,:,:) and calculate the RHSs + + ! at this moment the contains of wrk(:,:,:,1:3) are the convective terms in the RHS + ! which are not yet multiplied by "i" + ! wrk(:,:,:,4) contains the Laplace operator in Fourier space. To get the diffusion term + ! we need to take wrk(:,:,:,4) and multiply it by the velocity + + t1(6) = real(kmax,8) + + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! If the dealiasing option is 2/3-rule (dealias=0) then we retain the modes + ! inside the cube described by $| k_i | \leq k_{max}$, $i=1,2,3$. + ! The rest of the modes is purged + + if (ialias(i,j,k) .gt. 0) then + ! setting the Fourier components to zero + wrk(i ,j,k,1:3) = zip + wrk(i+1,j,k,1:3) = zip + + else + + ! RHS for u, v and w + do n = 1,3 + ! taking the convective term, multiply it by "i" + ! (see how it's done in x_fftw.f90) + ! and adding the diffusion term + rtmp = - wrk(i+1,j,k,n) + wrk(i ,j,k,4) * fields(i ,j,k,n) + wrk(i+1,j,k,n) = wrk(i ,j,k,n) + wrk(i+1,j,k,4) * fields(i+1,j,k,n) + wrk(i ,j,k,n) = rtmp + end do + + end if + + end do + end do + end do + + end if two_thirds_rule + +!-------------------------------------------------------------------------------- +! The second option (dealias=1). All pairwise products of velocities are +! dealiased using one phase shift of (dx/2,dy/2,dz/2). +!-------------------------------------------------------------------------------- + phase_shifting: if (dealias.eq.1) then + + ! work parameters + wrk(:,:,:,0) = zip + + ! getting all 6 products of velocities + do k = 1,nz + do j = 1,ny + do i = 1,nx + + t1(1) = wrk(i,j,k,1) * wrk(i,j,k,1) + t1(2) = wrk(i,j,k,1) * wrk(i,j,k,2) + t1(3) = wrk(i,j,k,1) * wrk(i,j,k,3) + t1(4) = wrk(i,j,k,2) * wrk(i,j,k,2) + t1(5) = wrk(i,j,k,2) * wrk(i,j,k,3) + t1(6) = wrk(i,j,k,3) * wrk(i,j,k,3) + do n = 1,6 + wrk(i,j,k,n) = t1(n) + end do + end do + end do + end do + + ! converting the products to the Fourier space + do n = 1,6 + call xFFT3d(1,n) + end do + + ! Building the RHS. + ! First, put into wrk arrays the convectove terms (that will be multiplyed by "i" + ! later) and the factor that corresponds to the diffusion + + ! Do not forget that in Fourier space the indicies are (ix, iz, iy) + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + + t1(1) = - ( akx(i) * wrk(i,j,k,1) + aky(k) * wrk(i,j,k,2) + akz(j) * wrk(i,j,k,3) ) + t1(2) = - ( akx(i) * wrk(i,j,k,2) + aky(k) * wrk(i,j,k,4) + akz(j) * wrk(i,j,k,5) ) + t1(3) = - ( akx(i) * wrk(i,j,k,3) + aky(k) * wrk(i,j,k,5) + akz(j) * wrk(i,j,k,6) ) + ! putting a factor from the diffusion term into t1(4) (and later in wrk4) + t1(4) = - nu * ( akx(i)**2 + aky(k)**2 + akz(j)**2 ) + do n = 1,4 + wrk(i,j,k,n) = t1(n) + end do + end do + end do + end do + + ! now use the actual fields from fields(:,:,:,:) to calculate the RHSs + + ! at this moment the contains of wrk(:,:,:,1:3) are the convective terms in the RHS + ! which are not yet multiplied by "i" + + ! wrk(:,:,:,4) contains the Laplace operator in Fourier space. To get the diffusion term + ! we need to take wrk(:,:,:,4) and multiply it by the velocity + + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! If the dealiasing option is (dealias=1) then we retain the modes + ! for which no more than one component of the k-vector is larger than nx/3. + ! The rest of the modes is purged. + + if (ialias(i,j,k) .gt. 1) then + ! setting the Fourier components to zero + wrk(i ,j,k,1:3) = zip + wrk(i+1,j,k,1:3) = zip + else + ! RHS for u, v and w + do n = 1,3 + ! taking the HALF of the convective term, multiply it by "i" + ! and adding the diffusion term + rtmp = - 0.5d0 * wrk(i+1,j,k,n) + wrk(i ,j,k,4) * fields(i ,j,k,n) + wrk(i+1,j,k,n) = 0.5d0 * wrk(i ,j,k,n) + wrk(i+1,j,k,4) * fields(i+1,j,k,n) + wrk(i ,j,k,n) = rtmp + end do + end if + + end do + end do + end do + + +!-------------------------------------------------------------------------------- +! Second part of the phase shifting technique +!-------------------------------------------------------------------------------- + + ! since wrk1...3 are taken by parts of RHS constructed earlier, we can use + ! only wrk0 and wrk4...6. + + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! computing sines and cosines for the phase shift of dx/2,dy/2,dz/2 + ! and putting them into wrk0 + wrk(i ,j,k,0) = cos(half*(akx(i )+aky(k)+akz(j))*dx) + wrk(i+1,j,k,0) = sin(half*(akx(i+1)+aky(k)+akz(j))*dx) + + ! wrk4 will have phase-shifted u + wrk(i ,j,k,4) = fields(i ,j,k,1) * wrk(i,j,k,0) - fields(i+1,j,k,1) * wrk(i+1,j,k,0) + wrk(i+1,j,k,4) = fields(i+1,j,k,1) * wrk(i,j,k,0) + fields(i ,j,k,1) * wrk(i+1,j,k,0) + + ! wrk5 will have phase-shifted v + wrk(i ,j,k,5) = fields(i ,j,k,2) * wrk(i,j,k,0) - fields(i+1,j,k,2) * wrk(i+1,j,k,0) + wrk(i+1,j,k,5) = fields(i+1,j,k,2) * wrk(i,j,k,0) + fields(i ,j,k,2) * wrk(i+1,j,k,0) + + end do + end do + end do + + ! transforming u+ and v+ into X-space + call xFFT3d(-1,4) + call xFFT3d(-1,5) + + ! now wrk4 and wrk5 contain u+ and v+ + + ! getting (u+)*(u+) in real space, converting it to Fourier space, + ! phase shifting back and adding -0.5*(the results) to the RHS for u + wrk(:,:,:,6) = wrk(:,:,:,4)**2 + call xFFT3d(1,6) + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + rtmp = wrk(i ,j,k,6) * wrk(i,j,k,0) + wrk(i+1,j,k,6) * wrk(i+1,j,k,0) + wrk(i+1,j,k,6) = wrk(i+1,j,k,6) * wrk(i,j,k,0) - wrk(i ,j,k,6) * wrk(i+1,j,k,0) + wrk(i ,j,k,6) = rtmp + end do + end do + end do + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + wrk(i ,j,k,1) = wrk(i ,j,k,1) + 0.5d0 * akx(i+1) * wrk(i+1,j,k,6) + wrk(i+1,j,k,1) = wrk(i+1,j,k,1) - 0.5d0 * akx(i ) * wrk(i ,j,k,6) + end do + end do + end do + + ! getting (u+)*(v+) in real space, converting it to Fourier space, + ! phase shifting back and adding -0.5*(the results) to the RHSs for u and v + wrk(:,:,:,6) = wrk(:,:,:,4)*wrk(:,:,:,5) + call xFFT3d(1,6) + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + rtmp = wrk(i ,j,k,6) * wrk(i,j,k,0) + wrk(i+1,j,k,6) * wrk(i+1,j,k,0) + wrk(i+1,j,k,6) = wrk(i+1,j,k,6) * wrk(i,j,k,0) - wrk(i ,j,k,6) * wrk(i+1,j,k,0) + wrk(i ,j,k,6) = rtmp + end do + end do + end do + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + wrk(i ,j,k,1) = wrk(i ,j,k,1) + 0.5d0 * aky(k) * wrk(i+1,j,k,6) + wrk(i+1,j,k,1) = wrk(i+1,j,k,1) - 0.5d0 * aky(k) * wrk(i ,j,k,6) + + wrk(i ,j,k,2) = wrk(i ,j,k,2) + 0.5d0 * akx(i+1) * wrk(i+1,j,k,6) + wrk(i+1,j,k,2) = wrk(i+1,j,k,2) - 0.5d0 * akx(i ) * wrk(i ,j,k,6) + end do + end do + end do + + ! getting (v+)*(v+) in real space, converting it to Fourier space, + ! phase shifting back and adding -0.5*(the results) to the RHS for v + wrk(:,:,:,6) = wrk(:,:,:,5)**2 + call xFFT3d(1,6) + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + rtmp = wrk(i ,j,k,6) * wrk(i,j,k,0) + wrk(i+1,j,k,6) * wrk(i+1,j,k,0) + wrk(i+1,j,k,6) = wrk(i+1,j,k,6) * wrk(i,j,k,0) - wrk(i ,j,k,6) * wrk(i+1,j,k,0) + wrk(i ,j,k,6) = rtmp + end do + end do + end do + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + wrk(i ,j,k,2) = wrk(i ,j,k,2) + 0.5d0 * aky(k) * wrk(i+1,j,k,6) + wrk(i+1,j,k,2) = wrk(i+1,j,k,2) - 0.5d0 * aky(k) * wrk(i ,j,k,6) + end do + end do + end do + + ! now get the (w+) in wrk6 + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + ! wrk6 will have phase-shifted w + wrk(i ,j,k,6) = fields(i ,j,k,3) * wrk(i,j,k,0) - fields(i+1,j,k,3) * wrk(i+1,j,k,0) + wrk(i+1,j,k,6) = fields(i+1,j,k,3) * wrk(i,j,k,0) + fields(i ,j,k,3) * wrk(i+1,j,k,0) + end do + end do + end do + ! transforming w+ into X-space + call xFFT3d(-1,6) + + ! at this point wrk4..6 contain (u+), (v+) and (w+) in real space. + ! the combinations that we have not dealt with are: uw, vw and ww. + ! we'll deal with all three of them at once. + + ! first get all three of these in wrk4...6 and + wrk(:,:,:,4) = wrk(:,:,:,4) * wrk(:,:,:,6) + wrk(:,:,:,5) = wrk(:,:,:,5) * wrk(:,:,:,6) + wrk(:,:,:,6) = wrk(:,:,:,6)**2 + + ! transform them into Fourier space + call xFFT3d(1,4) + call xFFT3d(1,5) + call xFFT3d(1,6) + + ! phase shift back to origianl grid and add to corresponding RHSs + do n = 4,6 + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + rtmp = wrk(i ,j,k,n) * wrk(i,j,k,0) + wrk(i+1,j,k,n) * wrk(i+1,j,k,0) + wrk(i+1,j,k,n) = wrk(i+1,j,k,n) * wrk(i,j,k,0) - wrk(i ,j,k,n) * wrk(i+1,j,k,0) + wrk(i ,j,k,n) = rtmp + end do + end do + end do + end do + + ! adding to corresponding RHSs + do k = 1,nz + do j = 1,ny + do i = 1,nx+1,2 + + ! If the dealiasing option is (dealias=1) then we retain the modes + ! for which no more than one component of the k-vector is larger than nx/3. + ! The rest of the modes is purged. + + if (ialias(i,j,k) .lt. 2) then + + wrk(i ,j,k,1) = wrk(i ,j,k,1) + 0.5d0 * akz(j) * wrk(i+1,j,k,4) + wrk(i+1,j,k,1) = wrk(i+1,j,k,1) - 0.5d0 * akz(j) * wrk(i ,j,k,4) + + wrk(i ,j,k,2) = wrk(i ,j,k,2) + 0.5d0 * akz(j) * wrk(i+1,j,k,5) + wrk(i+1,j,k,2) = wrk(i+1,j,k,2) - 0.5d0 * akz(j) * wrk(i ,j,k,5) + + wrk(i ,j,k,3) = wrk(i ,j,k,3) + 0.5d0 * & + (akx(i+1)*wrk(i+1,j,k,4) + aky(k)*wrk(i+1,j,k,5) + akz(j)*wrk(i+1,j,k,6)) + wrk(i+1,j,k,3) = wrk(i+1,j,k,3) - 0.5d0 * & + (akx(i )*wrk(i ,j,k,4) + aky(k)*wrk(i ,j,k,5) + akz(j)*wrk(i ,j,k,6)) + + else + wrk(i:i+1,j,k,1) = zip + wrk(i:i+1,j,k,2) = zip + wrk(i:i+1,j,k,3) = zip + end if + + end do + end do + end do + + end if phase_shifting + + ! if performing large eddy simulations, call LES subroutine to augment + ! the right hand side for velocioties + les_active: if (les) then + call les_rhs_velocity + end if les_active + + return +end subroutine rhs_velocity + + +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ +!================================================================================ + +subroutine test_rhs_velocity + + use m_openmpi + use m_io + use m_parameters + use m_fields + use m_work + use x_fftw + + implicit none + + integer :: i,j,k, n + real*8 :: a,b,c, x,y,z + + + ! defining very particular velocities so the RHS can be computed analytically + + if (task.eq.'hydro') then + + + write(out,*) 'inside.' + call flush(out) + + + a = 1.d0 + b = 1.d0 + c = 1.d0 + + do k = 1,nz + do j = 1,ny + do i = 1,nx + + x = dx*real(i-1) + y = dx*real(j-1) + z = dx*real(myid*nz + k-1) + + wrk(i,j,k,1) = sin(a * x) + wrk(i,j,k,2) = sin(b * y) + wrk(i,j,k,3) = sin(c * z) + end do + end do + end do + + write(out,*) 'did work' + call flush(out) + + + + do n = 1,3 + call xFFT3d(1,n) + fields(:,:,:,n) = wrk(:,:,:,n) + end do + + + write(out,*) 'did FFTs' + call flush(out) + + nu = 0.d0 + + call rhs_velocity + + write(out,*) 'got rhs' + call flush(out) + + do n = 1,3 + call xFFT3d(-1,n) + end do + + write(out,*) 'did FFTs' + call flush(out) + + + + do k = 1,nz + do j = 1,ny + do i = 1,nx + + x = dx*real(i-1) + y = dx*real(j-1) + z = dx*real(myid*nz + k-1) + + ! checking u + wrk(i,j,k,4) = -sin(a*x) * ( two*a*cos(a*x) + b*cos(b*y) + c*cos(c*z) + nu*a**2) + + ! checking v + wrk(i,j,k,5) = -sin(b*y) * ( two*b*cos(b*y) + a*cos(a*x) + c*cos(c*z) + nu*b**2) + + ! checking w + wrk(i,j,k,6) = -sin(c*z) * ( two*c*cos(c*z) + b*cos(b*y) + a*cos(a*x) + nu*c**2) + + + end do + end do + end do + +!!$ do k = 1,nz +!!$ write(out,"(3e15.6)") wrk(1,1,k,3),wrk(1,1,k,5),wrk(1,1,k,4) +!!$ end do + + wrk(:,:,:,0) = & + abs(wrk(:,:,:,1) - wrk(:,:,:,4)) + & + abs(wrk(:,:,:,2) - wrk(:,:,:,5)) + & + abs(wrk(:,:,:,3) - wrk(:,:,:,6)) + + print *,'Maximum error is ',maxval(wrk(1:nx,:,:,0)) + + + tmp4(:,:,:) = wrk(1:nx,:,:,1) - wrk(1:nx,:,:,4) + fname = 'e1.arr' + call write_tmp4 + + tmp4(:,:,:) = wrk(1:nx,:,:,2) - wrk(1:nx,:,:,5) + fname = 'e2.arr' + call write_tmp4 + + tmp4(:,:,:) = wrk(1:nx,:,:,3) - wrk(1:nx,:,:,6) + fname = 'e3.arr' + call write_tmp4 + + + + end if + return +end subroutine test_rhs_velocity diff --git a/velocity_rescale.f90 b/velocity_rescale.f90 new file mode 100644 index 0000000..a160a76 --- /dev/null +++ b/velocity_rescale.f90 @@ -0,0 +1,159 @@ +!================================================================================ +! Subroutine that rescales the current velocities. The rescales velocity +! will have the spectrum that is defined in the input file via parameters +! isp_type (spectrum type) and peak_wavenum (peak wavenumber). +! +! The program is copies from a part of init_velocity.f90. Some time in the +! future we should make it one routine that is called in init_velocity. +! +! Time-stamp: <2010-01-25 17:01:55 (chumakov)> +!================================================================================ + +subroutine velocity_rescale + + use m_openmpi + use m_parameters + use m_io + use m_fields + use x_fftw + + implicit none + + integer :: i, j, k, n + + real, allocatable :: rr(:) + real*8, allocatable :: e_spec(:), e_spec1(:) + integer *8, allocatable :: hits(:), hits1(:) + + integer :: n_shell + real*8 :: sc_rad1, sc_rad2 + + real*8 :: wmag, wmag2, ratio, fac + + + ! if Taylor-Green, return + if (isp_type.eq.-1) return + + +!================================================================================ + allocate( e_spec(kmax), e_spec1(kmax), rr(nx+2), hits(kmax), hits1(kmax), stat=ierr) + if (ierr.ne.0) stop "cannot allocate the init_velocity arrays" + + write(out,*) 'Rescaling the velocities' + call flush(out) + +!------------------------------------------------------------------------------- +! Making the spectrum to be what is prescribed in the input file <...>.in +!------------------------------------------------------------------------------- + + ! --- first get the energy spectrum (copied from m_stat.f90) + + ! need this normalization factor because the FFT is unnormalized + fac = one / real(nx*ny*nz_all)**2 + + ! zeroing out the arrays + e_spec1 = zip + e_spec = zip + hits = 0 + hits1 = 0 + + ! finding the total energy in each shell and number of hits in each shell + ! storing them in arrays hits1 and e_spec1 + do k = 1,nz + do j = 1,ny + do i = 1,nx + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax) then + hits1(n_shell) = hits1(n_shell) + 1 + e_spec1(n_shell) = e_spec1(n_shell) + & + fac * (fields(i,j,k,1)**2 + fields(i,j,k,2)**2 + fields(i,j,k,3)**2) + end if + end do + end do + end do + + ! reducing the number of hits and energy to two arrays on master node + count = kmax + call MPI_REDUCE(hits1,hits,count,MPI_INTEGER8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + count = kmax + call MPI_REDUCE(e_spec1,e_spec,count,MPI_REAL8,MPI_SUM,0,MPI_COMM_TASK,mpi_err) + + ! now the master node counts the energy density in each shell + if (myid.eq.0) then + fac = four/three * PI / two + do k = 1,kmax + sc_rad1 = real(k,8) + half + sc_rad2 = real(k,8) - half + if (k.eq.1) sc_rad2 = 0.d0 + if (hits(k).gt.0) then + e_spec(k) = e_spec(k) / hits(k) * fac * (sc_rad1**3 - sc_rad2**3) + else + e_spec(k) = zip + end if + end do + end if + + ! broadcasting the spectrum + count = kmax + call MPI_BCAST(e_spec,count,MPI_REAL8,0,MPI_COMM_TASK,mpi_err) + +!------------------------------------------------------------------------------- +! Now make the spectrum to be as desired +!------------------------------------------------------------------------------- + + ! first, define the desired spectrum + do k = 1,kmax + + wmag = real(k, 8) + ratio = wmag / peak_wavenum + + if (isp_type.eq.0) then + ! Plain Kolmogorov spectrum + e_spec1(k) = wmag**(-5.d0/3.d0) + + else if (isp_type.eq.1) then + ! Exponential spectrum + e_spec1(k) = ratio**3 / peak_wavenum * exp(-3.0D0*ratio) + + else if (isp_type.eq.3) then + ! Von Karman spectrum + fac = two * PI * ratio + e_spec1(k) = fac**4 / (one + fac**2)**3 + + else + write(out,*) "ERROR: WRONG INITIAL SPECTRUM TYPE: ",isp_type + call flush(out) + stop + + end if + end do + +! normalize it so it has the unit total energy + e_spec1 = e_spec1 / sum(e_spec1(1:kmax)) + + ! now go over all Fourier shells and multiply the velocities in a shell by + ! the sqrt of ratio of the resired to the current spectrum + do k = 1,nz + do j = 1,ny + do i = 1,nx+2 + + n_shell = nint(sqrt(real(akx(i)**2 + aky(k)**2 + akz(j)**2, 4))) + if (n_shell .gt. 0 .and. n_shell .le. kmax .and. e_spec(n_shell) .gt. zip) then + fields(i,j,k,1:3) = fields(i,j,k,1:3) * sqrt(e_spec1(n_shell)/e_spec(n_shell)) + else + fields(i,j,k,1:3) = zip + end if + + end do + end do + end do + + write(out,*) "Rescaled the velocities." + call flush(out) + + ! deallocate work arrays + deallocate(e_spec, e_spec1, rr, hits, hits1, stat=ierr) + + return +end subroutine velocity_rescale diff --git a/write_tmp4.f90 b/write_tmp4.f90 new file mode 100644 index 0000000..d0e5f7c --- /dev/null +++ b/write_tmp4.f90 @@ -0,0 +1,73 @@ +subroutine write_tmp4 + + use m_parameters + use m_io + use m_work + implicit none + + integer :: my_out=13, i,j,k + integer*4 :: sizes(3) + +!====================================================================== + + ! --- defining the size of whole array + sizes(1)=nx; sizes(2)=ny; sizes(3)=nz*numprocs; + count = nx*ny*nz + + if (myid.ne.master) then + id_to = master + tag = myid + call MPI_SEND(tmp4,count,MPI_REAL4,master,tag,MPI_COMM_TASK,mpi_err) + else +!! open(my_out,file=fname,form='binary') + open(my_out,file=fname,form='unformatted', access='stream') + write(my_out) sizes(1:3) + write(my_out) (((tmp4(i,j,k),i=1,nx),j=1,ny),k=1,nz) + + do id_from=1,numprocs-1 + tag = id_from + call MPI_RECV(tmp4,count,MPI_REAL4,id_from,tag,MPI_COMM_TASK,mpi_status,mpi_err) + write(my_out) (((tmp4(i,j,k),i=1,nx),j=1,ny),k=1,nz) + end do + close(my_out) + end if + +!====================================================================== + + return +end subroutine write_tmp4 + +!====================================================================== +subroutine write_tmp4_all + + use m_parameters + use m_io + use m_work + implicit none + + integer :: my_out=13, i,j,k + integer(kind=MPI_INTEGER_KIND) :: sizes(3), fh + integer(kind=MPI_OFFSET_KIND) :: offset + +!====================================================================== + + ! --- defining the size of whole array + sizes(1)=nx; sizes(2)=ny; sizes(3)=nz*numprocs; + + ! --- writing into the file with appropriate offset + call MPI_INFO_CREATE(mpi_info,mpi_err) + if(ierr.ne.0) stop '*** WRITE_TMP4_ALL: cannot create mpi_info' + + call MPI_FILE_OPEN(MPI_COMM_TASK,fname,MPI_MODE_WRONLY+MPI_MODE_CREATE,mpi_info,fh,mpi_err) + if (myid.eq.0) call MPI_FILE_WRITE_AT(fh,0,sizes,3,MPI_INTEGER4,mpi_status,mpi_err) + offset = 12 + myid*nx*ny*nz * 4 + count = nx * ny * nz + call MPI_FILE_WRITE_AT_ALL(fh,offset,tmp4,count,MPI_REAL4,mpi_status,mpi_err) + call MPI_FILE_CLOSE(fh,mpi_err) + call MPI_INFO_FREE(mpi_info,mpi_err) + +!====================================================================== + + return +end subroutine write_tmp4_all + diff --git a/x_fftw.f90 b/x_fftw.f90 new file mode 100644 index 0000000..a431471 --- /dev/null +++ b/x_fftw.f90 @@ -0,0 +1,1286 @@ +!==============================================================================! +! +! Fast Fourier Transform that uses FFTW3 library, +! pseudospectral DNS code +! Copyright (C) 2006 Sergei Chumakov, Natalia Vladimirova, Misha Stepanov +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the +! Free Software Foundation, Inc., +! 51 Franklin Street, Fifth Floor, +! Boston, MA 02110-1301, USA +! +!==============================================================================! + +MODULE x_fftw + +!==============================================================================! +! VARIABLES +!==============================================================================! + use m_parameters + use m_io + use m_fields + use m_work + use m_timing + implicit none + + ! FFTW parameters that do not change + integer(kind=8), parameter :: FFTW_ESTIMATE = 0 + integer(kind=8), parameter :: FFTW_FORWARD = -1 + integer(kind=8), parameter :: FFTW_BACKWARD = 1 + + ! dedicated arrays for parallel FFT + real(kind=8), allocatable :: xy_sheet(:, :), buff(:, :, :), z_stick(:) + + real*8, allocatable :: buff2(:,:,:) + + ! order of message passing between processors + integer(kind=4), allocatable :: order(:), order_matrix(:, :) + + ! the arrays to store FFTW plans for the 2D r2c or c2r steps + ! plan_r2c(1..nz, 1..n_scalars) + integer(kind=8), allocatable :: plan_r2c(:, :), plan_c2r(:, :) + integer(kind=8), allocatable :: plan_r2c_f(:, :), plan_c2r_f(:, :) + + ! FFTW plans for the 1D c2c forward/backward steps + integer(kind=8) :: plan_f_c2c, plan_b_c2c + + ! k-vectors ("a" added as arrays are real + real(kind=8), allocatable :: akx(:), aky(:), akz(:) + real(kind=8), allocatable :: coskx2(:), cosky2(:), coskz2(:) + real(kind=8), allocatable :: sinkx2(:), sinky2(:), sinkz2(:) + integer(kind=4), allocatable :: rezkax(:), rezkay(:), rezkaz(:) + + ! auxiliary parameters + integer(kind=4) :: nx21 + real(kind=8) :: norm + + ! array that contains indicator of aliasing when products are taken + integer(kind=1), allocatable :: ialias(:,:,:) + +!==============================================================================! +!==============================================================================! +CONTAINS +!==============================================================================! +!==============================================================================! +! SUBROUTINES +!==============================================================================! +!==============================================================================! +! Subroutine that allocates/deallocates the FFTW arrays +!==============================================================================! + subroutine X_FFTW_ALLOCATE(flag) + + implicit none + integer :: flag + + if (flag == 1) then + +!!$ print *,'FFTW_ALLOCATE: size(wrk,4) = ',size(wrk,4) +!!$ print *,'FFTW_ALLOCATE: bounds(wrk,4) = ',LBOUND(wrk,4),UBOUND(wrk,4) +!!$ write(out,*) 'FFTW_ALLOCATE: size(wrk,4) = ',size(wrk,4) +!!$ write(out,*) 'FFTW_ALLOCATE: bounds(wrk,4) = ',LBOUND(wrk,4),UBOUND(wrk,4) +!!$ call flush(out) + + allocate(& + plan_r2c(nz, LBOUND(wrk,4):UBOUND(wrk,4)), & + plan_c2r(nz, LBOUND(wrk,4):UBOUND(wrk,4)), & + plan_r2c_f(nz, LBOUND(fields,4):UBOUND(fields,4)), & + plan_c2r_f(nz, LBOUND(fields,4):UBOUND(fields,4)), & + xy_sheet(nx, ny), buff(nx + 2, nz, nz), & + z_stick(2 * nz_all), akx(nx + 2), aky(nz), akz(nz_all), & + rezkax(nx + 2), rezkay(nz), rezkaz(nx), & + coskx2(nx + 2), cosky2(nz), coskz2(nx), & + sinkx2(nx + 2), sinky2(nz), sinkz2(nx), & + order(numprocs - 1), & + buff2(nx+2, nz, nz), & + ialias(nx+2, ny, nz), stat = ierr) + + + +!!$ write(out,*) 'Size of plan_r2c:',SIZE(plan_r2c,1),SIZE(plan_r2c,2) +!!$ write(out,*) 'Size of plan_c2r:',SIZE(plan_c2r,1),SIZE(plan_c2r,2) +!!$ call flush(out) + + if (ierr /= 0) then + write (out, *) '*** X_FFTW_ALLOCATE: cannot allocate' + call my_exit(-1) + end if + + write(out,*) "x_fftw_allocated." + call flush(out) + + ! assigning temporary values to allocated arrays + plan_r2c = 0 + plan_c2r = 0 + xy_sheet = zip + buff = zip + buff2 = zip + z_stick = zip + order = 0 + ialias = 0 + + + + elseif (flag == -1) then + if (allocated(plan_r2c)) then + deallocate(plan_r2c, plan_c2r, plan_r2c_f, plan_c2r_f, & + xy_sheet, buff, z_stick, order, & + akx, aky, akz, rezkax, rezkay, rezkaz, coskx2, cosky2, coskz2,& + sinkx2, sinky2, sinkz2, buff2, ialias) + end if + write(out,*) "x_fftw_deallocated." + call flush(out) + else + write (out, *) '*** X_FFTW_ALLOCATE: Wrong value of flag:', flag + call my_exit(-1) + end if + + return + end subroutine X_FFTW_ALLOCATE + +!==============================================================================! +! Program that initializes the auxilary arrays for FFT +!==============================================================================! + + subroutine x_fftw_init + + implicit none + + integer :: itmp, ix, iy, iz, n, i, j, k + real *8 :: rnx3 + + ! write(out, *) 'Initializing FFT arrays.' + ! call flush(out) + +!------------------------------------------------------------------------------! +! filling up the array order_matrix +!------------------------------------------------------------------------------! + allocate(order_matrix(numprocs, numprocs), stat = ierr) + if (ierr /= 0) then + write(out,*) '*** X_FFTW_INIT: Cannot allocate order_matrix' + call my_exit(-1) + end if + + order_matrix(1, 1) = 0 + itmp = 1 + + do while (itmp < numprocs) + + do ix = 1, itmp + do iy = 1, itmp + + order_matrix(ix + itmp, iy) = order_matrix(ix, iy) + itmp + order_matrix(ix, iy + itmp) = order_matrix(ix, iy) + itmp + order_matrix(ix + itmp, iy + itmp) = order_matrix(ix, iy) + + end do + end do + + itmp = 2 * itmp + + end do + +!------------------------------------------------------------------------------! +! filling the array order and deallocating order_matrix +!------------------------------------------------------------------------------! + do ix = 1, numprocs + if (order_matrix(ix, myid + 1) /= 0) then + order(order_matrix(ix, myid + 1)) = ix - 1 + end if + end do + deallocate(order_matrix) + +!------------------------------------------------------------------------------! +! initializing FFTW plans for the 1st step in FFT --- 2D r2c +!------------------------------------------------------------------------------! +!!$ print *,'FFTW_INIT: size(wrk,4) = ',size(wrk,4) +!!$ print *,'FFTW_INIT: bounds(wrk,4) = ',LBOUND(wrk,4),UBOUND(wrk,4) + + do n = LBOUND(wrk,4),UBOUND(wrk,4) + do iz = 1, nz + call DFFTW_PLAN_DFT_R2C_2D(plan_r2c(iz, n), nx, ny, & + xy_sheet, wrk(1, 1, iz, n), & + FFTW_ESTIMATE) + end do + end do + + ! separately initializing the plans for FFT of the array "fields" + do n = LBOUND(fields,4),UBOUND(fields,4) + do iz = 1, nz + call DFFTW_PLAN_DFT_R2C_2D(plan_r2c_f(iz, n), nx, ny, & + xy_sheet, fields(1, 1, iz, n), & + FFTW_ESTIMATE) + end do + end do + +!------------------------------------------------------------------------------! +! initializing FFTW plan for the 2nd step in FFT --- 1D c2c +!------------------------------------------------------------------------------! + call DFFTW_PLAN_DFT_1D(plan_f_c2c, nz_all, z_stick, z_stick, & + FFTW_FORWARD, FFTW_ESTIMATE) + +!------------------------------------------------------------------------------! +! initializing FFTW plan for the 1st step in IFFT --- 1D c2c +!------------------------------------------------------------------------------! + call DFFTW_PLAN_DFT_1D(plan_b_c2c, nz_all, z_stick, z_stick, & + FFTW_BACKWARD, FFTW_ESTIMATE) + +!------------------------------------------------------------------------------! +! initializing FFTW plans for the 2nd step in IFFT --- 2D c2r +!------------------------------------------------------------------------------! + do n = LBOUND(wrk,4),UBOUND(wrk,4) + do iz = 1, nz + call DFFTW_PLAN_DFT_C2R_2D(plan_c2r(iz, n), nx, ny, & + wrk(1, 1, iz, n), xy_sheet, & + FFTW_ESTIMATE) + end do + end do + + ! separately intializing the plans for FFT of the array "fields" + do n = LBOUND(fields,4),UBOUND(fields,4) + do iz = 1, nz + call DFFTW_PLAN_DFT_C2R_2D(plan_c2r_f(iz, n), nx, ny, & + fields(1, 1, iz, n), xy_sheet, & + FFTW_ESTIMATE) + end do + end do + +!------------------------------------------------------------------------------! +! initializing some useful constants +!------------------------------------------------------------------------------! + nx21 = nx / 2 + 1 + norm = one / real(nx * ny * nz_all, 8) + +!------------------------------------------------------------------------------! +! filling up the wavenumber arrays akx, aky, akz +! filling up the wavenumber arrays rezkax, rezkay, rezkaz +!------------------------------------------------------------------------------! + ! in Fourier space it is (nx / 2 + 1) complex numbers along kx-axis + do ix = 1, nx + 1, 2 + akx(ix) = real((ix - 1) / 2, 8) + akx(ix + 1) = akx(ix) + coskx2(ix) = dcos(half * akx(ix)) + sinkx2(ix) = dsin(half * akx(ix)) + coskx2(ix + 1) = coskx2(ix) + sinkx2(ix + 1) = sinkx2(ix) + rezkax(ix) = 0 + if (dabs(akx(ix)) > (real(nz_all, 8)) / 3.0D0) rezkax(ix) = 1 + end do + ! in Fourier space ky-axis is distributed among the processors + do iy = 1, nz + aky(iy) = real(myid * nz + iy - 1, 8) + if (aky(iy) > (0.5D0 * real(ny, 8))) aky(iy) = aky(iy) - real(ny, 8) + cosky2(iy) = dcos(half * aky(iy)) + sinky2(iy) = dsin(half * aky(iy)) + rezkay(iy) = 0 + if (dabs(aky(iy)) > (real(ny, 8)) / 3.0D0) rezkay(iy) = 1 + end do + ! in Fourier space the z wavenumbers are aligned along the second index + do iz = 1, ny + akz(iz) = real(iz - 1, 8) + if (akz(iz) > (0.5D0 * real(nz_all, 8))) akz(iz) = akz(iz) - real(nz_all, 8) + coskz2(iz) = dcos(half * akz(iz)) + sinkz2(iz) = dsin(half * akz(iz)) + rezkaz(iz) = 0 + if (dabs(akz(iz)) > (real(nz_all, 8)) / 3.0D0) rezkaz(iz) = 1 + end do + + ! Definition of the array ialias. + ! The array ialias is just the number of wavenumbers at (i,j,k) that have + ! their magnitude higher than nx/3. This is needed in dealiasing procedures. + rnx3 = real(nx/3, 8) + do k = 1,nz + if (abs(aky(k)) .gt. rnx3) ialias(:,:,k) = 1 + do j = 1,ny + if (abs(akz(j)) .gt. rnx3) ialias(:,j,k) = ialias(:,j,k) + 1 + do i = 1,nx+2 + if (abs(akx(i)) .gt. rnx3) ialias(i,j,k) = ialias(i,j,k) + 1 + end do + end do + end do + + + write(out,*) "x_fftw arrays are intiialized." + call flush(out) + + return + end subroutine x_fftw_init + + +!==============================================================================! +! Subroutine that performs the FFT of a 3-D variable. The variable is +! contained within the array "wrk(:, :, :, n)". Note that the +! result of FFT has different coordinate arrangement: in physical +! space it is (x, y, z), and in Fourier space it is (kx, kz, ky). +! Details can be extracted from very graphic comments in the body of +! the subroutine. +!==============================================================================! + + subroutine xxxFFT3d(flag, n) + + use m_openmpi + implicit none + + integer :: flag, n + integer :: ix, iy, iz + + real(kind=8) :: rtmp + + integer(kind=MPI_INTEGER_KIND) :: iproc + + if (flag == 1) then + +!------------------------------------------------------------------------------! +! Direct FFT, step 1: 2-D real-to-complex transform +!------------------------------------------------------------------------------! +! +! R2C (# = ny) A y A y (# = ny) A k_y +! | | | +! +---+---+---+---+ + +---+---+---+---+ +! / / / / /| /| / / / / /| +! / / / / wrk xy_sheet / / / / wrk +! / / / / / | / | / / / / / | +! +---+---+---+---+ | + | +---+---+---+---+ | +! | | | | | | | | R2C | | | | | | +! | | | | | | -----> | | -----> | | | | | | +! | | | | | | | | | | | | | | +! <---| | | | | + | + <---| | | | | + +! z | | | | | / | / z | | | | | / +! | | | | | / | / | | | | | / +! | | | | |/ |/ | | | | |/ +! +---+---+---+---+ + +---+---+---+---+ +! / / / +! (# = nx) V x V x (# = nx / 2 + 1) V k_x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + xy_sheet(ix, iy) = wrk(ix, iy, iz, n) + end do + end do + +!!$ write(out,*) 'before r2c',iz,n,plan_r2c(iz, n),size(plan_r2c,1),size(plan_r2c,2) +!!$ call flush(out) + + call DFFTW_EXECUTE(plan_r2c(iz, n)) + end do +!------------------------------------------------------------------------------! +! Direct FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! +! +! MPI (# = ny) A k_y +---+ +---+ (# = nz_all) A z +! | /buff| /buff| | +! +---+---+---+---+ / / + / / + +---+---+---+---+ +! / /+++/ / /| / / / MPI / / / / / / / /| +! / /+++/ / wrk +---+ / ----> +---+ / / ../. / / wrk +! / /+++/ / / | | |/ | |/ / ../.. / / / | +! +---+---+---+---+ | +---+ +---+ +---+---+---+---+ | +! | |+++| | | | A \ |...|. | | | | +! | | \____ | ____/ `--->+++| | | | | +! | | | |\_____/| |+++| | | | | +! <---| | | | | + <---| | | | | + +! z | | | | | / k_y | | | | | / +! (nz_all / numprocs)| | / (# = ny / numprocs)| | / +! | | | | |/ | | | | |/ +! +---+---+---+---+ +---+---+---+---+ +! / / +! V k_x V k_x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + +!!$ write(out,*) 'before diagonal message' +!!$ call flush(out) + + + do iz = 1, nz - 1 + do iy = iz + 1, nz + do ix = 1, nx + 2 + rtmp = wrk(ix, myid * nz + iy, iz, n) + wrk(ix, myid * nz + iy , iz, n) = & + & wrk(ix, myid * nz + iz, iy, n) + wrk(ix, myid * nz + iz, iy, n) = rtmp + end do + end do + end do + ! - sending and receiving MPI messages + +!!$ write(out,*) 'before MPI message' +!!$ call flush(out) + + count = (nx+2) * ny * nz + + do iproc = 1, numprocs - 1 + do iy = 1, nz + do iz = 1, nz + buff(:, iz, iy) = wrk(:, order(iproc) * nz + iy, iz, n) + end do + end do + call MPI_SENDRECV_REPLACE(buff, & + & (nx + 2) * nz * nz, MPI_REAL8, & + & order(iproc), myid * numprocs + order(iproc), & + & order(iproc), order(iproc) * numprocs + myid, & + & MPI_COMM_TASK, mpi_status, mpi_err) + + do iy = 1, nz + do iz = 1, nz + wrk(:, order(iproc) * nz + iz, iy, n) = buff(:, iz, iy) + end do + end do + end do +!------------------------------------------------------------------------------! +! Direct FFT, step 3: one-dimensional complex-to-complex FFT +!------------------------------------------------------------------------------! +! +! C2C-> A z A k_z +! | A z A k_z | +! +---+---+---+---+ | | +---+---+---+---+ +! / / / / /| + + / / / / /| +! / / / / wrk | | / / / / wrk +! / / / / / | z_stick z_stick / / / / / | +! +---+---+---+---+ | | | +---+---+---+---+ | +! | | | | | | | C2C | | | | | | | +! | | | | | | -----> | -----> | -----> | | | | | | +! | | | | | | | | | | | | | | +! <---| | | | | + | | <---| | | | | + +! k_y | | | | | / + + k_y | | | | | / +! | | | | | / | | | | | / +! | | | | |/ | | | | |/ +! +---+---+---+---+ +---+---+---+---+ +! / / +! V k_x V k_x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + +!!$ write(out,*) 'before 1d fft' +!!$ call flush(out) + + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = wrk(2 * ix - 1, iz, iy, n) + z_stick(2 * iz) = wrk(2 * ix, iz, iy, n) + end do + +!!$ write(out,*) 'before 1d fft',iy +!!$ call flush(out) + + call DFFTW_EXECUTE(plan_f_c2c) + do iz = 1, nz_all + wrk(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + wrk(2 * ix, iz, iy, n) = z_stick(2 * iz) + end do + end do + end do +!------------------------------------------------------------------------------! + + elseif (flag == -1) then + +!------------------------------------------------------------------------------! +! Inverse FFT, step 1: one-dimensionsal complex-to-complex transform +!------------------------------------------------------------------------------! +! +! <-C2C A k_z A z +! | A k_z A z | +! +---+---+---+---+ | | +---+---+---+---+ +! / / / / /| + + / / / / /| +! / / / / wrk | | / / / / wrk +! / / / / / | z_stick z_stick / / / / / | +! +---+---+---+---+ | | | +---+---+---+---+ | +! | | | | | | | C2C | | | | | | | +! | | | | | | -----> | -----> | -----> | | | | | | +! | | | | | | | | | | | | | | +! <---| | | | | + | | <---| | | | | + +! k_y | | | | | / + + k_y | | | | | / +! | | | | | / | | | | | / +! | | | | |/ | | | | |/ +! +---+---+---+---+ +---+---+---+---+ +! / / +! V k_x V k_x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = wrk(2 * ix - 1, iz, iy, n) + z_stick(2 * iz) = wrk(2 * ix, iz, iy, n) + end do + call DFFTW_EXECUTE(plan_b_c2c) + do iz = 1, nz_all + wrk(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + wrk(2 * ix, iz, iy, n) = z_stick(2 * iz) + end do + end do + end do +!------------------------------------------------------------------------------! +! Inverse FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! +! +! MPI (# = nz_all) A z +---+ +---+ (# = ny) A k_y +! | /buff| /buff| | +! +---+---+---+---+ / / + / / + +---+---+---+---+ +! / /+++/ / /| / / / MPI / / / / / / / /| +! / /+++/ / wrk +---+ / ----> +---+ / / ../. / / wrk +! / /+++/ / / | | |/ | |/ / ../.. / / / | +! +---+---+---+---+ | +---+ +---+ +---+---+---+---+ | +! | |+++| | | | A \ |...|. | | | | +! | | \____ | ____/ `--->+++| | | | | +! | | | |\_____/| |+++| | | | | +! <---| | | | | + <---| | | | | + +! k_y | | | | | / z | | | | | / +! (# = ny / numprocs)| | / (# = nz_all / numprocs)| | / +! | | | | |/ | | | | |/ +! +---+---+---+---+ +---+---+---+---+ +! / / +! V k_x V k_x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + do iy = 1, nz - 1 + do iz = iy + 1, nz + do ix = 1, nx + 2 + rtmp = wrk(ix, myid * nz + iz, iy, n) + wrk(ix, myid * nz + iz , iy, n) = & + & wrk(ix, myid * nz + iy, iz, n) + wrk(ix, myid * nz + iy, iz, n) = rtmp + end do + end do + end do + ! - sending and receiving MPI messages + do iproc = 1, numprocs - 1 + do iz = 1, nz + do iy = 1, nz + buff(:, iy, iz) = wrk(:, order(iproc) * nz + iz, iy, n) + end do + end do + call MPI_SENDRECV_REPLACE(buff, & + & (nx + 2) * nz * nz, MPI_REAL8, & + & order(iproc), myid * numprocs + order(iproc), & + & order(iproc), order(iproc) * numprocs + myid, & + & MPI_COMM_TASK, mpi_status, mpi_err) + do iz = 1, nz + do iy = 1, nz + wrk(:, order(iproc) * nz + iy, iz, n) = buff(:, iy, iz) + end do + end do + end do +!------------------------------------------------------------------------------! +! Inverse FFT, step 3: 2-D complex-to-real transform +!------------------------------------------------------------------------------! +! +! C2R (# = ny) A k_y A y (# = ny) A y +! | | | +! +---+---+---+---+ + +---+---+---+---+ +! / / / / /| /| / / / / /| +! / / / / wrk xy_sheet / / / / wrk +! / / / / / | / | / / / / / | +! +---+---+---+---+ | + | +---+---+---+---+ | +! | | | | | | C2R | | | | | | | | +! | | | | | | -----> | | -----> | | | | | | +! | | | | | | | | | | | | | | +! <---| | | | | + | + <---| | | | | + +! z | | | | | / | / z | | | | | / +! | | | | | / | / | | | | | / +! | | | | |/ |/ | | | | |/ +! +---+---+---+---+ + +---+---+---+---+ +! / / / +! (# = nx / 2 + 1) V k_x V x (# = nx) V x +! +! 3 2 1 0 --- myid 3 2 1 0 --- myid +! +!------------------------------------------------------------------------------! + do iz = 1, nz + call DFFTW_EXECUTE(plan_c2r(iz, n)) + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, n) = norm * xy_sheet(ix, iy) + end do + end do + end do +!------------------------------------------------------------------------------! + + end if + + return + end subroutine xxxFFT3d + + +!==============================================================================! +! Subroutine that calculates the derivative. +! +! Takes variable from wrk(:,:,:,n), differentiates it and put into +! wrk(:,:,:,nto). All happens in Fourier space +!==============================================================================! + + subroutine x_derivative(n,axis,nto) + + implicit none + integer :: ix, iy, iz, n, nto + real(kind=8) :: rtmp + character :: axis + + ! in Fourier space it is (kx, kz, ky) + ! here we multiply by k-vector, will multiply by i later + select case (axis) + case ('x') + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx + 2 + wrk(ix, iz, iy, nto) = akx(ix) * wrk(ix, iz, iy, n) + end do + end do + end do + case ('y') + do iy = 1, nz + wrk(:, :, iy, nto) = aky(iy) * wrk(:, :, iy, n) + end do + case ('z') + do iy = 1, nz + do iz = 1, nz_all + wrk(:, iz, iy, nto) = akz(iz) * wrk(:, iz, iy, n) + end do + end do + case default + write (out, *) '*** x_derivative: wrong value of axis: ', axis + call my_exit(-1) + end select + + ! multiplying wrk(ix) + i wrk(ix + 1) by i + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx + 1, 2 + rtmp = -wrk(ix + 1, iz, iy, nto) + wrk(ix + 1, iz, iy, nto) = wrk(ix, iz, iy, nto) + wrk(ix, iz, iy, nto) = rtmp + end do + end do + end do + + + end subroutine x_derivative + + +!==============================================================================! +! Subroutine --- dealiasing. +!==============================================================================! + + subroutine x_dealiasing(n1, n2) + + implicit none + + integer :: n1, n2, tmp1, tmp2, tmp + integer :: ix, iy, iz + + tmp = 0 + tmp1 = 1 + tmp2 = 2 + + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx + 2 + if (rezkax(ix) + rezkay(iy) + rezkaz(iz) > 1) then + wrk(ix, iz, iy, n1) = zip + wrk(ix, iz, iy, n2) = zip + end if + wrk(ix, iz, iy, tmp1) = wrk(ix, iz, iy, n1) + wrk(ix, iz, iy, tmp2) = wrk(ix, iz, iy, n2) + end do + end do + end do + + call xFFT3d(-1, tmp1) + call xFFT3d(-1, tmp2) + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, tmp) = wrk(ix, iy, iz, tmp1) * & + & wrk(ix, iy, iz, tmp2) + end do + end do + end do + +! phase-shift, x direction + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx21, 2 + wrk(ix, iz, iy, tmp1) = coskx2(ix) * & + wrk(ix, iz, iy, n1) - & + & sinkx2(ix) * & + wrk(ix + 1, iz, iy, n1) + wrk(ix + 1, iz, iy, tmp1) = coskx2(ix) * & + wrk(ix + 1, iz, iy, n1) + & + & sinkx2(ix) * & + wrk(ix, iz, iy, n1) + wrk(ix, iz, iy, tmp2) = coskx2(ix) * & + wrk(ix, iz, iy, n2) - & + & sinkx2(ix) * & + wrk(ix + 1, iz, iy, n2) + wrk(ix + 1, iz, iy, tmp2) = coskx2(ix) * & + wrk(ix + 1, iz, iy, n2) + & + & sinkx2(ix) * & + wrk(ix, iz, iy, n2) + end do + end do + end do + + call xFFT3d(-1, tmp1) + call xFFT3d(-1, tmp2) + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, tmp) = wrk(ix, iy, iz, tmp) + & + wrk(ix, iy, iz, tmp1) * & + & wrk(ix, iy, iz, tmp2) + end do + end do + end do + +! phase-shift, y direction + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx21, 2 + wrk(ix, iz, iy, tmp1) = cosky2(iy) * & + wrk(ix, iz, iy, n1) - & + & sinky2(iy) * & + wrk(ix + 1, iz, iy, n1) + wrk(ix + 1, iz, iy, tmp1) = cosky2(iy) * & + wrk(ix + 1, iz, iy, n1) + & + & sinky2(iy) * & + wrk(ix, iz, iy, n1) + wrk(ix, iz, iy, tmp2) = cosky2(iy) * & + wrk(ix, iz, iy, n2) - & + & sinky2(iy) * & + wrk(ix + 1, iz, iy, n2) + wrk(ix + 1, iz, iy, tmp2) = cosky2(iy) * & + wrk(ix + 1, iz, iy, n2) + & + & sinky2(iy) * & + wrk(ix, iz, iy, n2) + end do + end do + end do + + call xFFT3d(-1, tmp1) + call xFFT3d(-1, tmp2) + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, tmp) = wrk(ix, iy, iz, tmp) + & + wrk(ix, iy, iz, tmp1) * & + & wrk(ix, iy, iz, tmp2) + end do + end do + end do + +! phase-shift, z direction + do iy = 1, nz + do iz = 1, nz_all + do ix = 1, nx21, 2 + wrk(ix, iz, iy, tmp1) = coskz2(iz) * & + wrk(ix, iz, iy, n1) - & + & sinkz2(iz) * & + wrk(ix + 1, iz, iy, n1) + wrk(ix + 1, iz, iy, tmp1) = coskz2(iz) * & + wrk(ix + 1, iz, iy, n1) + & + & sinkz2(iz) * & + wrk(ix, iz, iy, n1) + wrk(ix, iz, iy, tmp2) = coskz2(iz) * & + wrk(ix, iz, iy, n2) - & + & sinkz2(iz) * & + wrk(ix + 1, iz, iy, n2) + wrk(ix + 1, iz, iy, tmp2) = coskz2(iz) * & + wrk(ix + 1, iz, iy, n2) + & + & sinkz2(iz) * & + wrk(ix, iz, iy, n2) + end do + end do + end do + + call xFFT3d(-1, tmp1) + call xFFT3d(-1, tmp2) + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, tmp) = 0.25D0 * (wrk(ix, iy, iz, tmp) + & + wrk(ix, iy, iz, tmp1) * & + & wrk(ix, iy, iz, tmp2)) + end do + end do + end do + + call xFFT3d(1, tmp) + + end subroutine x_dealiasing + +!==============================================================================! +!==============================================================================! +!==============================================================================! +!==============================================================================! +! Subroutine that performs the FFT of a 3-D variable. The variable is +! contained within the array "wrk(:, :, :, n)". Note that the +! result of FFT has different coordinate arrangement: in physical +! space it is (x, y, z), and in Fourier space it is (kx, kz, ky). +! Details can be extracted from very graphic comments in the body of +! the subroutine. +!==============================================================================! + + subroutine xFFT3d(flag, n) + + use m_openmpi + use m_io + implicit none + + integer :: flag, n + integer :: ix, iy, iz, i, j, k + + INTEGER (KIND=MPI_INTEGER_KIND) :: tag1, tag2, iproc + + real(kind=8) :: rtmp + + if (flag == 1) then + +!------------------------------------------------------------------------------! +! Direct FFT, step 1: 2-D real-to-complex transform +!------------------------------------------------------------------------------! + + if(benchmarking) then + call system_clock(i81,dcpu) + bm(11) = bm(11) - i81 + end if + + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + xy_sheet(ix, iy) = wrk(ix, iy, iz, n) + end do + end do + call DFFTW_EXECUTE(plan_r2c(iz, n)) + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(1) = bm(1) + i82 - i81 + i81 = i82 + end if + +!------------------------------------------------------------------------------! +! Direct FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + + do iz = 1, nz - 1 + do iy = iz + 1, nz + do ix = 1, nx + 2 + rtmp = wrk(ix, myid * nz + iy, iz, n) + wrk(ix, myid * nz + iy , iz, n) = & + & wrk(ix, myid * nz + iz, iy, n) + wrk(ix, myid * nz + iz, iy, n) = rtmp + end do + end do + end do + + ! - sending and receiving MPI messages + + count = (nx+2) * nz * nz + + do iproc = 1, numprocs - 1 + +!!$ ! The following order should be implemented in the future, +!!$ ! because it shaves off about 4% of time +!!$ id_to = mod(myid+iproc,numprocs) +!!$ id_from = mod(myid-iproc+numprocs,numprocs) + + id_to = order(iproc) + id_from = id_to + + tag1 = myid*numprocs + iproc + tag2 = id_from*numprocs + iproc + + do iy = 1, nz + do iz = 1, nz + buff(:, iz, iy) = wrk(:, id_to * nz + iy, iz, n) + end do + end do + + call MPI_SENDRECV(& + buff, count, MPI_REAL8, id_to, tag1, & + buff2, count, MPI_REAL8, id_from, tag2, & + MPI_COMM_TASK, mpi_status, mpi_err) + + do iy = 1, nz + do iz = 1, nz + wrk(:, id_from * nz + iz, iy, n) = buff2(:, iz, iy) + end do + end do + + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(2) = bm(2) + i82 - i81 + i81 = i82 + end if + +!------------------------------------------------------------------------------! +! Direct FFT, step 3: one-dimensional complex-to-complex FFT +!------------------------------------------------------------------------------! + + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = wrk(2 * ix - 1, iz, iy, n) + z_stick(2 * iz) = wrk(2 * ix, iz, iy, n) + end do + + call DFFTW_EXECUTE(plan_f_c2c) + do iz = 1, nz_all + wrk(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + wrk(2 * ix, iz, iy, n) = z_stick(2 * iz) + end do + end do + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(3) = bm(3) + i82 - i81 + bm(11) = bm(11) + i82 + end if + +!------------------------------------------------------------------------------! + + elseif (flag == -1) then + +!------------------------------------------------------------------------------! +! Inverse FFT, step 1: one-dimensionsal complex-to-complex transform +!------------------------------------------------------------------------------! + if(benchmarking) then + call system_clock(i81,dcpu) + bm(12) = bm(12) - i81 + end if + + + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = wrk(2 * ix - 1, iz, iy, n) + z_stick(2 * iz) = wrk(2 * ix, iz, iy, n) + end do + call DFFTW_EXECUTE(plan_b_c2c) + do iz = 1, nz_all + wrk(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + wrk(2 * ix, iz, iy, n) = z_stick(2 * iz) + end do + end do + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(4) = bm(4) + i82 - i81 + i81 = i82 + end if +!------------------------------------------------------------------------------! +! Inverse FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + do iy = 1, nz - 1 + do iz = iy + 1, nz + do ix = 1, nx + 2 + rtmp = wrk(ix, myid * nz + iz, iy, n) + wrk(ix, myid * nz + iz , iy, n) = & + & wrk(ix, myid * nz + iy, iz, n) + wrk(ix, myid * nz + iy, iz, n) = rtmp + end do + end do + end do + + + ! - sending and receiving MPI messages + + count = (nx+2) * nz * nz + + do iproc = 1, numprocs - 1 + +!!$ ! This order should be implemented in the future because this saves +!!$ ! about 4% of wallclock time for FFT +!!$ id_to = mod(myid+iproc,numprocs) +!!$ id_from = mod(myid-iproc+numprocs,numprocs) + + id_to = order(iproc) + id_from = order(iproc) + + tag1 = myid*numprocs + iproc + tag2 = id_from*numprocs + iproc + + do iz = 1, nz + do iy = 1, nz + buff(:, iy, iz) = wrk(:, id_to * nz + iz, iy, n) + end do + end do + + call MPI_SENDRECV(& + buff, count, MPI_REAL8, id_to, tag1, & + buff2, count, MPI_REAL8, id_from, tag2, & + MPI_COMM_TASK, mpi_status, mpi_err) + + do iz = 1, nz + do iy = 1, nz + wrk(:, id_from * nz + iy, iz, n) = buff2(:, iy, iz) + end do + end do + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(5) = bm(5) + i82 - i81 + i81 = i82 + end if + +!------------------------------------------------------------------------------! +! Inverse FFT, step 3: 2-D complex-to-real transform +!------------------------------------------------------------------------------! + do iz = 1, nz + call DFFTW_EXECUTE(plan_c2r(iz, n)) + do iy = 1, ny + do ix = 1, nx + wrk(ix, iy, iz, n) = norm * xy_sheet(ix, iy) + end do + end do + end do + + if (benchmarking) then + call system_clock(i82,dcpu) + bm(6) = bm(6) + i82 - i81 + bm(12) = bm(12) + i82 + end if +!------------------------------------------------------------------------------! + + end if + + return + end subroutine xFFT3d + +!================================================================================ + + + +!==============================================================================! +! Subroutine that performs the FFT of a 3-D variable. The variable is +! contained within the array "fields(:, :, :, n)". Note that the +! result of FFT has different coordinate arrangement: in physical +! space it is (x, y, z), and in Fourier space it is (kx, kz, ky). +!==============================================================================! + + subroutine xFFT3d_fields(flag, n) + + use m_openmpi + use m_io + use m_fields + implicit none + + integer :: flag, n + integer :: ix, iy, iz, i, j, k + + INTEGER (KIND=MPI_INTEGER_KIND) :: tag1, tag2, iproc + + real(kind=8) :: rtmp + + if (flag == 1) then + +!------------------------------------------------------------------------------! +! Direct FFT, step 1: 2-D real-to-complex transform +!------------------------------------------------------------------------------! + do iz = 1, nz + do iy = 1, ny + do ix = 1, nx + xy_sheet(ix, iy) = fields(ix, iy, iz, n) + end do + end do + call DFFTW_EXECUTE(plan_r2c_f(iz, n)) + end do + +!------------------------------------------------------------------------------! +! Direct FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + + do iz = 1, nz - 1 + do iy = iz + 1, nz + do ix = 1, nx + 2 + rtmp = fields(ix, myid * nz + iy, iz, n) + fields(ix, myid * nz + iy , iz, n) = & + & fields(ix, myid * nz + iz, iy, n) + fields(ix, myid * nz + iz, iy, n) = rtmp + end do + end do + end do + + ! - sending and receiving MPI messages + + count = (nx+2) * nz * nz + + do iproc = 1, numprocs - 1 + +!!$ ! The following order should be implemented in the future, +!!$ ! because it shaves off about 4% of time +!!$ id_to = mod(myid+iproc,numprocs) +!!$ id_from = mod(myid-iproc+numprocs,numprocs) + + id_to = order(iproc) + id_from = id_to + + tag1 = myid*numprocs + iproc + tag2 = id_from*numprocs + iproc + + do iy = 1, nz + do iz = 1, nz + buff(:, iz, iy) = fields(:, id_to * nz + iy, iz, n) + end do + end do + + call MPI_SENDRECV(& + buff, count, MPI_REAL8, id_to, tag1, & + buff2, count, MPI_REAL8, id_from, tag2, & + MPI_COMM_TASK, mpi_status, mpi_err) + + do iy = 1, nz + do iz = 1, nz + fields(:, id_from * nz + iz, iy, n) = buff2(:, iz, iy) + end do + end do + + end do + +!------------------------------------------------------------------------------! +! Direct FFT, step 3: one-dimensional complex-to-complex FFT +!------------------------------------------------------------------------------! + + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = fields(2 * ix - 1, iz, iy, n) + z_stick(2 * iz ) = fields(2 * ix , iz, iy, n) + end do + + call DFFTW_EXECUTE(plan_f_c2c) + do iz = 1, nz_all + fields(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + fields(2 * ix , iz, iy, n) = z_stick(2 * iz) + end do + end do + end do +!------------------------------------------------------------------------------! + + elseif (flag == -1) then + +!------------------------------------------------------------------------------! +! Inverse FFT, step 1: one-dimensionsal complex-to-complex transform +!------------------------------------------------------------------------------! + do iy = 1, nz + do ix = 1, nx21 + do iz = 1, nz_all + z_stick(2 * iz - 1) = fields(2 * ix - 1, iz, iy, n) + z_stick(2 * iz ) = fields(2 * ix , iz, iy, n) + end do + call DFFTW_EXECUTE(plan_b_c2c) + do iz = 1, nz_all + fields(2 * ix - 1, iz, iy, n) = z_stick(2 * iz - 1) + fields(2 * ix , iz, iy, n) = z_stick(2 * iz) + end do + end do + end do +!------------------------------------------------------------------------------! +! Inverse FFT, step 2: transposing the variable via MPI messaging +!------------------------------------------------------------------------------! + ! - "diagonal" messages, no need to use MPI + do iy = 1, nz - 1 + do iz = iy + 1, nz + do ix = 1, nx + 2 + rtmp = fields(ix, myid * nz + iz, iy, n) + fields(ix, myid * nz + iz , iy, n) = & + & fields(ix, myid * nz + iy, iz, n) + fields(ix, myid * nz + iy, iz, n) = rtmp + end do + end do + end do + + + ! - sending and receiving MPI messages + + count = (nx+2) * nz * nz + + do iproc = 1, numprocs - 1 + +!!$ ! This order should be implemented in the future because this saves +!!$ ! about 4% of wallclock time for FFT +!!$ id_to = mod(myid+iproc,numprocs) +!!$ id_from = mod(myid-iproc+numprocs,numprocs) + + id_to = order(iproc) + id_from = order(iproc) + + tag1 = myid*numprocs + iproc + tag2 = id_from*numprocs + iproc + + do iz = 1, nz + do iy = 1, nz + buff(:, iy, iz) = fields(:, id_to * nz + iz, iy, n) + end do + end do + + call MPI_SENDRECV(& + buff, count, MPI_REAL8, id_to, tag1, & + buff2, count, MPI_REAL8, id_from, tag2, & + MPI_COMM_TASK, mpi_status, mpi_err) + + do iz = 1, nz + do iy = 1, nz + fields(:, id_from * nz + iy, iz, n) = buff2(:, iy, iz) + end do + end do + end do +!------------------------------------------------------------------------------! +! Inverse FFT, step 3: 2-D complex-to-real transform +!------------------------------------------------------------------------------! + do iz = 1, nz + call DFFTW_EXECUTE(plan_c2r_f(iz, n)) + do iy = 1, ny + do ix = 1, nx + fields(ix, iy, iz, n) = norm * xy_sheet(ix, iy) + end do + end do + end do +!------------------------------------------------------------------------------! + + end if + + return + end subroutine xFFT3d_fields + +!================================================================================ + +end MODULE X_FFTW