diff --git a/CodesEnVrac/CodeGH/CMake b/CodesEnVrac/CodeGH/CMake
new file mode 120000
index 0000000000000000000000000000000000000000..af160f9126941418c0041528616ca5e2b612707d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/CMake
@@ -0,0 +1 @@
+../../CMake
\ No newline at end of file
diff --git a/CodesEnVrac/CodeGH/CMakeLists.txt b/CodesEnVrac/CodeGH/CMakeLists.txt
new file mode 100755
index 0000000000000000000000000000000000000000..4c6a676ed27f53832907b97f45377cb881f21de7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/CMakeLists.txt
@@ -0,0 +1,162 @@
+#=======================================================
+# cmake utility to compile and install G.H. soft
+#
+# F. Pérignon, dec. 2011
+#
+#=======================================================
+
+# ============= Global cmake Settings =============
+# Set minimum version for cmake
+cmake_minimum_required(VERSION 2.8)
+# Set policy
+cmake_policy(VERSION 2.8)
+# Set cmake modules directory (i.e. the one which contains all user-defined FindXXX.cmake files among other things)
+set(CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/CMake)
+# Force out-of-source build
+include(OutOfSourceBuild)
+# Some usefull macros
+include(MyTools)
+
+# ============= Specific settings for PPMCore =============
+# In this file (PPMCoreSettings.cmake) we set all variables
+# required to compile and install PPMCore such as the name of
+# the library to be created, the place where we can find the sources,
+# the version number of the current package ...
+
+option(BUILD_SHARED_LIBS "Enable dynamic library build, default = ON" ON)
+option(VERBOSE_MODE "enable verbose mode for cmake exec" ON)
+
+# cmake project name
+set(PROJECT_NAME vicper)
+
+# The list of all dirs containing sources to be compiled
+# Any file in those dirs will be used to create the executable
+set(${PROJECT_NAME}_SRCDIRS
+ src-common
+ src-sphere
+# src-THI
+ )
+# Matching expr for files to be compiled.
+set(EXTS *.f *.f90 *.f95)
+# Matching expr for headers (install purpose)
+set(EXTS_HDRS *.i *.h)
+
+# ============= The project =============
+# Set project name and project languages
+# => this automatically defines:
+# - ${PROJECT_NAME}_BINARY_DIR : where you have run cmake, i.e. the place for compilation
+# - ${PROJECT_NAME}_SOURCE_DIR : where sources (.f and .h and this CMakeLists.txt) are located
+# Note that because of OutOfSourceBuild, binary_dir and source_dir must be different.
+project(${PROJECT_NAME} Fortran)
+
+# ============= Search for libraries =============
+# We search for libraries Parmes depends on and
+# set the compile/link conf (-I and -L opt)
+find_package(FFTW REQUIRED)
+include_directories(${FFTW_INCLUDE_DIRS})
+set(LIBS ${LIBS} ${FFTW_LIBRARIES})
+if(VERBOSE_MODE)
+ message(STATUS "FFTW include dirs : ${FFTW_INCLUDE_DIRS}")
+ message(STATUS "FFTW libraries : ${FFTW_LIBRARIES}")
+endif(VERBOSE_MODE)
+
+# ============= Prepare compilation =============
+# Force a default build type if not provided by user
+# CMAKE_BUILD_TYPE = empty, Debug, Release, RelWithDebInfo or MinSizeRel.
+if (NOT CMAKE_BUILD_TYPE)
+ set (CMAKE_BUILD_TYPE RELEASE CACHE STRING "Choose the type of build, options are: None, Debug, Release, RelWithDebInfo or MinSizeRel." FORCE)
+endif (NOT CMAKE_BUILD_TYPE)
+
+# If the project uses Fortran ...
+# Set module files directory (i.e. where .mod will be created)
+set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/Modules)
+# Add compilation flags:
+include(TestFortranAcceptsFlag)
+# Try -ffree-form option (GNU)
+CHECK_Fortran_ACCEPTS_FLAG(-ffree-form Fortran_HAVE_ffree_form)
+if(Fortran_HAVE_ffree_form)
+ set(Fortran_Free_Flag "-ffree-form")
+else(Fortran_HAVE_ffree_form)
+ # Try -free (IFORT)
+ CHECK_Fortran_ACCEPTS_FLAG(-free Fortran_HAVE_free)
+ if(Fortran_HAVE_free)
+ set(Fortran_Free_Flag "-free")
+ else(Fortran_HAVE_free)
+ message(FATAL_ERROR "Can not find Fortran compiler free-form flag.")
+ # No other tests ... todo if we need exotic compilers ...
+ endif(Fortran_HAVE_free)
+endif(Fortran_HAVE_ffree_form)
+#append_Fortran_FLAGS(${Fortran_Free_Flag})
+#append_Fortran_FLAGS("-Wall -ffixed-form")
+append_Fortran_FLAGS("-fPIC")# -mcmodel medium -shared-intel")
+
+# ============= Source and header files list =============
+# We scan all files with matching extension in directories
+# containing sources.
+# Source and header files list:
+foreach(_DIR ${${PROJECT_NAME}_SRCDIRS})
+ set(_DIR_FILES)
+ foreach(_EXT ${EXTS}) # Source files
+ file(GLOB _DIR_FILES_EXT ${_DIR}/${_EXT})
+ if(_DIR_FILES_EXT)
+ list(APPEND ${PROJECT_NAME}_SRC ${_DIR_FILES_EXT})
+ endif()
+ endforeach()
+ foreach(_EXT ${EXTS_HDRS}) # Headers
+ file(GLOB _DIR_FILES_EXT ${_DIR}/${_EXT})
+ if(_DIR_FILES_EXT)
+ list(APPEND ${PROJECT_NAME}_HDRS ${_DIR_FILES_EXT})
+ endif()
+ endforeach()
+endforeach()
+# We add headers to source files
+list(APPEND ${PROJECT_NAME}_SRC ${${PROJECT_NAME}_HDRS})
+
+display(${PROJECT_NAME}_HDRS)
+
+# -I
+include_directories(${${PROJECT_NAME}_SRCDIRS})
+include_directories(${CMAKE_Fortran_MODULE_DIRECTORY})
+
+# ============= Creates the executable =============
+add_executable(${PROJECT_NAME} ${${PROJECT_NAME}_SRC})
+
+# libs to link with EXE_NAME
+target_link_libraries(${PROJECT_NAME} ${LIBS})
+
+# ============= Prepare install =============
+# Everything will be installed in CMAKE_INSTALL_PREFIX/lib include and share
+include(InstallPackage)
+
+install(TARGETS ${PROJECT_NAME}
+ RUNTIME DESTINATION bin
+ )
+
+set(INSTALL_INCLUDE_DIR include CACHE PATH
+ "Installation directory for header files")
+install(FILES ${${PROJECT_NAME}_HDRS} DESTINATION "${INSTALL_INCLUDE_DIR}")
+install(DIRECTORY ${CMAKE_BINARY_DIR}/Modules DESTINATION "${INSTALL_INCLUDE_DIR}")
+
+# ============= RPATH =============
+# Concerning rpath see for example http://www.itk.org/Wiki/CMake_RPATH_handling
+
+# --------------------------------------------
+# do not skip the full RPATH for the build tree
+set(CMAKE_SKIP_BUILD_RPATH FALSE)
+# when building, don't use the install RPATH already
+# (but later on when installing)
+set(CMAKE_BUILD_WITH_INSTALL_RPATH FALSE)
+# the RPATH to be used when installing
+set(CMAKE_INSTALL_RPATH "${CMAKE_INSTALL_PREFIX}/lib")
+# add the automatically determined parts of the RPATH
+# which point to directories outside the build tree to the install RPATH
+set(CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE)
+
+# ============= Summary =============
+if(VERBOSE_MODE)
+ message(STATUS "====================== Summary ======================")
+ message(STATUS " Compiler : ${CMAKE_Fortran_COMPILER}")
+ message(STATUS " Sources are in : ${CMAKE_SOURCE_DIR}")
+ message(STATUS " Project will be installed in ${CMAKE_INSTALL_PREFIX}")
+ message(STATUS "====================== ======= ======================")
+endif()
diff --git a/CodesEnVrac/CodeGH/Examples/C_IN.DAT b/CodesEnVrac/CodeGH/Examples/C_IN.DAT
new file mode 100644
index 0000000000000000000000000000000000000000..36bf39a267a246d2aac5748851246162988d122a
--- /dev/null
+++ b/CodesEnVrac/CodeGH/Examples/C_IN.DAT
@@ -0,0 +1,15 @@
+NX - number of particles in x direction
+128
+t stop
+30.
+coef penalisation (en facteur de 1/delt)
+100000.
+Reynolds ou anu selon les cas
+133
+coeff LES
+0.
+Frequence impression resultat
+0.5
+width (=eps/dx)
+0.1
+
diff --git a/CodesEnVrac/CodeGH/INSTALL b/CodesEnVrac/CodeGH/INSTALL
new file mode 100755
index 0000000000000000000000000000000000000000..eef5ab3993255a6b74616299f6e2da1811fba1eb
--- /dev/null
+++ b/CodesEnVrac/CodeGH/INSTALL
@@ -0,0 +1,32 @@
+
+Pour compiler/linker/installer l'executable "vicper"
+
+sources : le répertoire (chemin absolu) où se trouvent les sources ET le CMakeLists.txt (i.e CodeGH du dépôt svn)
+build : un répertoire n'importe où (mais pas dans les sources du code)
+rep_install : là où on veut installer le binaire
+rep_simu : là où on va faire tourner la simu
+Nbprocs : nombre de procs dispo sur la machine
+
+Il faut que les compilos soient accessibles, ainsi que la lib fftw qui va avec.
+Par exemple sur Abel:
+module load intel/ifort-9.0
+module load fftw-3.2.2-intel
+
+cd build
+export FC=ifort F77=ifort (ou FC=gfortran F77=gfortran, au choix)
+cmake -DCMAKE_INSTALL_PREFIX=rep_install sources
+make -j N
+make install
+
+
+Utilisation :
+rep_simu doit contenir un C_IN.DAT avec les bons paramètres.
+
+cd rep_simu
+rep_install/bin/vicper
+
+et voila ...
+
+Pour se simplifier la vie :
+export PATH=${PATH}:rep_install/bin
+
diff --git a/CodesEnVrac/CodeGH/main/main.f b/CodesEnVrac/CodeGH/main/main.f
new file mode 100644
index 0000000000000000000000000000000000000000..cf528858d5970685c20e2b4a4a6c7bf1c596f2a8
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main.f
@@ -0,0 +1,418 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=4.5
+ t2=5.
+ t3=5.5
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+c t1=3.4
+c t2=3.8
+c t3=3.6
+ t4=6.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128:
+ nx3=128
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=1000.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.5*dx1/vmax1)
+c delt=0.5*dx2/vmax
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+ delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25*dx3/dvmax)
+c if ((dvmax.ne.0.).and.(korder.eq.2))
+c 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3/dx3
+ k_delt3=int(delt3/delt)
+ if (k_delt3.eq.0) then
+ k_delt=int(delt/delt3)
+ k_delt3=1
+ k_delt=k_delt+1
+ delt3=delt/float(k_delt)
+ else
+ delt3=float(k_delt3)*delt
+ k_delt=1
+ endif
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ print*,'TIME ',time
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ do 111 ksubite=1,k_delt
+ print*,ic,k_delt3
+ if ((ic.eq.k_delt3)) then
+
+ np_bl=3
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt2,np_bl,ntagz)
+ call z_advect(dt2,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+ endif
+
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+
+ endif
+111 continue
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_burgers.f b/CodesEnVrac/CodeGH/main/main_burgers.f
new file mode 100644
index 0000000000000000000000000000000000000000..2d495df44694a8348c56ebbbdf2641a32e19a8d4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_burgers.f
@@ -0,0 +1,154 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=(xmax-xmin)/float(nx1)
+ dx2=(xmax-xmin)/float(nx2)
+ zmax=xmax
+
+ circlim=0.00001
+ nx=nx1
+ dx=dx1
+
+ t1=0.6
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+ t1=3.4
+ t2=3.8
+ t3=3.6
+ t4=5.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=nx1
+ dx3=(xmax-xmin)/float(nx3)
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nx1
+ nz1=nx1
+ dy2=dx2
+ dz2=dx2
+ ny2=nx2
+ nz2=nx2
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+
+ call init_burgers
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ call velox_burgers(vmax,dvmax)
+ print*,' time, VMAX, DVmax = ',time,vmax,dvmax,dvmax/dx3
+
+c determination pas de temps:
+ delt3=0.4*dx3/vmax
+c delt3=0.
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.2*dx3/dvmax)
+ print*,' CFLs ',delt3*vmax/dx3
+ dt=delt3
+ np_bl=1
+
+
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+223 continue
+
+ time=time+dt
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(33,*) psi1(i,5,5)
+ write(34,*) ug(i,5,5)
+ enddo
+ close(33)
+
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_freeb.f b/CodesEnVrac/CodeGH/main/main_freeb.f
new file mode 100644
index 0000000000000000000000000000000000000000..d1c324b9fc746ed499860645ac3cbc45aa5a7358
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_freeb.f
@@ -0,0 +1,434 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+ drho=10.
+ drho=0.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ nx=nx2
+ dx=dx2
+
+ t1=0.5
+ dtcompt=0.05
+ t2=0.15
+ t3=0.2
+ t4=0.25
+ t5=0.3
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128 ou 256:
+ nx3=nx1
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+c dt max pour diffusion
+ dtmax=0.5*dx1*dx1/anu
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call bubble(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c seuil de omax et dvmax pour eviter les trop gros dt:
+ omax=amax1(omax,10.)
+ dvmax=amax1(dvmax,10.)
+
+c determination pas de temps:
+ if ((ic.eq.0)) then
+ delt=.1/abs(omax)
+ if (vmax1.gt.0.) delt=amax1(delt,0.5*dx1/vmax1)
+ delt=amin1(delt,dtmax)
+c delt=0.5*dx2/vmax
+c delt3=2.*dx3/vmax
+c delt3=0.5*dx2/vmax
+ delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25/dvmax)
+c if ((dvmax.ne.0.).and.(korder.eq.2))
+c 1 delt3=amax1(delt3,0.5/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3
+ k_delt3=int(delt3/delt)
+ if (k_delt3.eq.0) then
+ k_delt=int(delt/delt3)
+ k_delt3=1
+ k_delt=k_delt+1
+ delt3=delt/float(k_delt)
+ else
+ delt3=float(k_delt3)*delt
+ k_delt=1
+ endif
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ print*,'TIME ',time
+
+ call stretch_freeb(drho)
+ tau=0.001
+ tau=0.01
+ tau=0.1
+ jc=2
+ call stension(tau,jc)
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ do 111 ksubite=1,k_delt
+ print*,ic,k_delt3
+ if ((ic.eq.k_delt3)) then
+
+ np_bl=3
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt2,np_bl,ntagz)
+ call z_advect(dt2,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+ endif
+
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+
+ endif
+111 continue
+
+ tcompt=tcompt+delt
+ if ((time.ge.t1).and.(tcompt.ge.dtcompt)) then
+ tcompt=0.
+c if (((time.gt.t1).and.(time.le.t1+1.5*delt3)).
+c 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt3)).
+c 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt3)).
+c 1 or.((time.gt.t5).and.(time.le.t5+1.5*delt3)).
+c 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt3))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ uu=sqrt(vxg(i,j,k)**2+vyg(i,j,k)**2+vzg(i,j,k)**2)
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,uu)
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_freeb_full.f b/CodesEnVrac/CodeGH/main/main_freeb_full.f
new file mode 100644
index 0000000000000000000000000000000000000000..5904f3b31ddc8458e0cdf7f38c48645c7c85e145
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_freeb_full.f
@@ -0,0 +1,433 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+ drho=10.
+ drho=0.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ nx=nx2
+ dx=dx2
+
+ t1=0.5
+ dtcompt=0.05
+ t2=0.15
+ t3=0.2
+ t4=0.25
+ t5=0.3
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128 ou 256:
+ nx3=nx1
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+c dt max pour diffusion
+ dtmax=0.5*dx1*dx1/anu
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call bubble(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c seuil de omax et dvmax pour eviter les trop gros dt:
+ omax=amax1(omax,10.)
+ dvmax=amax1(dvmax,10.)
+
+c determination pas de temps:
+ if ((ic.eq.0)) then
+ delt=.1/abs(omax)
+ if (vmax1.gt.0.) delt=amax1(delt,0.5*dx1/vmax1)
+ delt=amin1(delt,dtmax)
+c delt=0.5*dx2/vmax
+c delt3=2.*dx3/vmax
+c delt3=0.5*dx2/vmax
+ delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25/dvmax)
+c if ((dvmax.ne.0.).and.(korder.eq.2))
+c 1 delt3=amax1(delt3,0.5/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3
+ k_delt3=int(delt3/delt)
+ if (k_delt3.eq.0) then
+ k_delt=int(delt/delt3)
+ k_delt3=1
+ k_delt=k_delt+1
+ delt3=delt/float(k_delt)
+ else
+ delt3=float(k_delt3)*delt
+ k_delt=1
+ endif
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ print*,'TIME ',time
+
+ call stretch_freeb(drho)
+ tau=0.001
+ tau=0.01
+ tau=0.1
+ jc=2
+ call stension(tau,jc)
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ do 111 ksubite=1,k_delt
+ print*,ic,k_delt3
+ if ((ic.eq.k_delt3)) then
+
+ np_bl=3
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt2,np_bl,ntagz)
+ call z_advect(dt2,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+ endif
+
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+
+ endif
+111 continue
+
+ tcompt=tcompt+delt
+ if ((time.ge.t1).and.(tcompt.ge.dtcompt)) then
+ tcompt=0.
+c if (((time.gt.t1).and.(time.le.t1+1.5*delt3)).
+c 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt3)).
+c 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt3)).
+c 1 or.((time.gt.t5).and.(time.le.t5+1.5*delt3)).
+c 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt3))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_freeb_small.f b/CodesEnVrac/CodeGH/main/main_freeb_small.f
new file mode 100644
index 0000000000000000000000000000000000000000..4a82e6fc864064efc9f0b38faf8b3ce667c79076
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_freeb_small.f
@@ -0,0 +1,198 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+ drho=10.
+ drho=0.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ nx=nx2
+ dx=dx2
+
+ t1=0.5
+ dtcompt=0.05
+ t2=0.15
+ t3=0.2
+ t4=0.25
+ t5=0.3
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128 ou 256:
+ nx3=nx1
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+c dt max pour diffusion
+ dtmax=0.5*dx1*dx1/anu
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+ call bubble(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=0.
+ istep=0
+
+ dt=0.01
+ tau=0.1
+ jc=8
+ call stension(tau,jc)
+ do k=1,nx1
+ do j=1,nx1
+ do i=1,nx1
+ omg1(i,j,k)=dt*strg1(i,j,k)
+ omg2(i,j,k)=dt*strg2(i,j,k)
+ omg3(i,j,k)=dt*strg3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+
+
+ open(24,file='filerho')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ open(24,file='filevelox')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ uu=sqrt(vxg(i,j,k)**2+vyg(i,j,k)**2+vzg(i,j,k)**2)
+c uu=sqrt(psi1(i,j,k)**2+psi2(i,j,k)**2+psi3(i,j,k)**2)
+ write(24,*) amax1(0.00001,uu)
+ enddo
+ enddo
+ enddo
+ close(24)
+
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_full.f b/CodesEnVrac/CodeGH/main/main_full.f
new file mode 100644
index 0000000000000000000000000000000000000000..ffca36884a4fd92e080e3e995170ef4a07896ace
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_full.f
@@ -0,0 +1,401 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.6
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+ t1=3.4
+ t2=3.8
+ t3=3.6
+ t4=5.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((kk.gt.1).and.(ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.5*dx1/vmax1)
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+c delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25*dx3/dvmax)
+ if ((dvmax.ne.0.).and.(korder.eq.2))
+ 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3/dx3
+ k_delt3=max(1,int(delt3/delt))
+ delt3=float(k_delt3)*delt
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ if (kk.ge.1) then
+
+
+ print*,'TIME ',time
+
+ endif
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ if (ic.eq.k_delt3) then
+
+ np_bl=1
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+
+ endif
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+ endif
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_full2.f b/CodesEnVrac/CodeGH/main/main_full2.f
new file mode 100644
index 0000000000000000000000000000000000000000..bffd93aaba58e19a4bae505698e153c9d37ea170
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_full2.f
@@ -0,0 +1,416 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=5.
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+c t1=3.4
+c t2=3.8
+ t3=3.6
+ t4=4.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128:
+ nx3=128
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=1000.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.5*dx1/vmax1)
+c delt=0.5*dx2/vmax
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+ delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.12*dx3/dvmax)
+c if ((dvmax.ne.0.).and.(korder.eq.2))
+c 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3/dx3
+ k_delt3=int(delt3/delt)
+ if (k_delt3.eq.0) then
+ k_delt=int(delt/delt3)
+ k_delt3=1
+ k_delt=k_delt+1
+ delt3=delt/float(k_delt)
+ else
+ delt3=float(k_delt3)*delt
+ k_delt=1
+ endif
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ print*,'TIME ',time
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ do 111 ksubite=1,k_delt
+ print*,ic,k_delt3
+ if ((ic.eq.k_delt3)) then
+
+ np_bl=3
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+ endif
+
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+
+ endif
+111 continue
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_full_nosplit.f b/CodesEnVrac/CodeGH/main/main_full_nosplit.f
new file mode 100644
index 0000000000000000000000000000000000000000..5019db500ff5f1d0401b3b9a7a0962bae6b5aa2d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_full_nosplit.f
@@ -0,0 +1,425 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.6
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+ t1=3.4
+ t2=3.8
+ t3=3.6
+ t4=5.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ npart2=0
+ do k=1,nz2
+ do j=1,ny2
+ do i=1,nx2
+ if (ug(i,j,k).gt.0.0001) then
+ npart2=npart2+1
+ xp2(npart2)=x0+float(i-1)*dx2
+ yp2(npart2)=y0+float(j-1)*dx2
+ zp2(npart2)=z0+float(k-1)*dx2
+ phip(npart2)=ug(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((kk.gt.1).and.(ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.25*dx1/vmax1)
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+c delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25*dx3/dvmax)
+ if ((dvmax.ne.0.).and.(korder.eq.2))
+ 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3/dx3
+ k_delt3=max(1,int(delt3/delt))
+ delt3=float(k_delt3)*delt
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ if (kk.ge.1) then
+
+
+ print*,'TIME ',time
+
+ endif
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ if (ic.eq.k_delt3) then
+
+ np_bl=1
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+
+c RK 2 pour advection particules xp2
+
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2)
+ do i=1,npart2
+ xp20(i)=xp2(i)
+ yp20(i)=yp2(i)
+ zp20(i)=zp2(i)
+ xp2(i)=xp2(i)+0.5*dt*vx2(i)
+ yp2(i)=yp2(i)+0.5*dt*vy2(i)
+ zp2(i)=zp2(i)+0.5*dt*vz2(i)
+ enddo
+c call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2)
+ do i=1,npart2
+ xp2(i)=xp20(i)+dt*vx2(i)
+ yp2(i)=yp20(i)+dt*vy2(i)
+ zp2(i)=zp20(i)+dt*vz2(i)
+ enddo
+
+c remesh tensoriel
+
+ call remesh_rho(npart2,phip,
+ 1 xp2,yp2,zp2)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+ endif
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_full_split.f b/CodesEnVrac/CodeGH/main/main_full_split.f
new file mode 100644
index 0000000000000000000000000000000000000000..b5a41d5f8ce42b477da57462f07e6d8dc178bce2
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_full_split.f
@@ -0,0 +1,401 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.6
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+ t1=3.4
+ t2=3.8
+ t3=3.6
+ t4=5.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((kk.gt.1).and.(ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.25*dx1/vmax1)
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+c delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25*dx3/dvmax)
+ if ((dvmax.ne.0.).and.(korder.eq.2))
+ 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, ' LCFL ',dvmax*delt3/dx3
+ k_delt3=max(1,int(delt3/delt))
+ delt3=float(k_delt3)*delt
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ if (kk.ge.1) then
+
+
+ print*,'TIME ',time
+
+ endif
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ if (ic.eq.k_delt3) then
+
+ np_bl=1
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+
+ endif
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+ endif
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_old.f b/CodesEnVrac/CodeGH/main/main_old.f
new file mode 100644
index 0000000000000000000000000000000000000000..162646b67e90609431d22a1554e4844fbd65f21d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_old.f
@@ -0,0 +1,445 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=16.*dx1
+ zmax=0.5
+ zmax=xmax
+ yt=0.55
+ yb=0.45
+c yt=1.
+c yb=0.
+
+ t1=0.6
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=0.
+ t4=0.
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+ j2=1+nint(yt/dx1)
+ j1=1+nint(yb/dx1)
+ yt=float(j2-1)*dx1
+ yb=float(j1-1)*dx1
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call jet(npart1,npart2,xp1,yp1,zp1,
+c 1 xp2,yp2,zp2,omx,omy,omz,phip,dv1)
+ call readfield(npart1,npart2,xp1,yp1,zp1,
+ 1 xp2,yp2,zp2,omx,omy,omz,phip,dv1)
+
+ print*,'npart1,npart2 ',npart1,npart2
+c call stream
+c call velox_stream
+ call velox
+ call veloxaux(nx3,vmax)
+
+ OPEN(33,file='VOLUMES',status='unknown')
+ OPEN(34,file='DECAY')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+ do i=1,npart2
+ xp20(i)=xp2(i)
+ yp20(i)=yp2(i)
+ zp20(i)=zp2(i)
+ enddo
+
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ if (kk.ge.1) then
+
+
+ print*,'TIME ',time
+
+ endif
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1,nx4)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,circlim,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+ call velox
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ if (ic.eq.k_delt3) then
+
+c transport pour particules de rho avec RK2 splitte
+
+c call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp2(i)=xp20(i)+delt3*vx2(i)/2.
+ yp2(i)=yp20(i)+delt3*vy2(i)/2.
+ zp2(i)=zp20(i)+delt3*vz2(i)/2.
+ if (xp2(i).lt.xmin) xp2(i)=xp2(i)+xmax-xmin
+ if (xp2(i).gt.xmax) xp2(i)=xp2(i)-xmax+xmin
+ if (yp2(i).lt.ymin) yp2(i)=yp2(i)+ymax-ymin
+ if (yp2(i).gt.ymax) yp2(i)=yp2(i)-ymax+ymin
+ if (zp2(i).lt.zmin) zp2(i)=zp2(i)+zmax-zmin
+ if (zp2(i).gt.zmax) zp2(i)=zp2(i)-zmax+zmin
+ enddo
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+c call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp2(i)=xp20(i)+delt3*vx2(i)
+ yp2(i)=yp20(i)
+ zp2(i)=zp20(i)
+ if (xp2(i).lt.xmin) xp2(i)=xp2(i)+xmax-xmin
+ if (xp2(i).gt.xmax) xp2(i)=xp2(i)-xmax+xmin
+ enddo
+
+ call remesh_rhox(npart2,circlim,phip,
+ 1 xp2,yp2,zp2)
+
+ print*, 'NPART apres remesh_rhox ',npart2
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+c call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp20(i)=xp2(i)
+ yp20(i)=yp2(i)
+ zp20(i)=zp2(i)
+ xp2(i)=xp20(i)-delt3*vx2(i)/2.
+ yp2(i)=yp20(i)+delt3*vy2(i)/2.
+ zp2(i)=zp20(i)+delt3*vz2(i)/2.
+ if (xp2(i).lt.xmin) xp2(i)=xp2(i)+xmax-xmin
+ if (xp2(i).gt.xmax) xp2(i)=xp2(i)-xmax+xmin
+ if (yp2(i).lt.ymin) yp2(i)=yp2(i)+ymax-ymin
+ if (yp2(i).gt.ymax) yp2(i)=yp2(i)-ymax+ymin
+ if (zp2(i).lt.zmin) zp2(i)=zp2(i)+zmax-zmin
+ if (zp2(i).gt.zmax) zp2(i)=zp2(i)-zmax+zmin
+ enddo
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+c call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp2(i)=xp20(i)
+ yp2(i)=yp20(i)+delt3*vy2(i)
+ zp2(i)=zp20(i)
+ if (yp2(i).lt.ymin) yp2(i)=yp2(i)+ymax-ymin
+ if (yp2(i).gt.ymax) yp2(i)=yp2(i)-ymax+ymin
+ enddo
+
+ call remesh_rhoy(npart2,circlim,phip,
+ 1 xp2,yp2,zp2)
+
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+c call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp20(i)=xp2(i)
+ yp20(i)=yp2(i)
+ zp20(i)=zp2(i)
+ xp2(i)=xp20(i)-delt3*vx2(i)/2.
+ yp2(i)=yp20(i)-delt3*vy2(i)/2.
+ zp2(i)=zp20(i)+delt3*vz2(i)/2.
+ if (xp2(i).lt.xmin) xp2(i)=xp2(i)+xmax-xmin
+ if (xp2(i).gt.xmax) xp2(i)=xp2(i)-xmax+xmin
+ if (yp2(i).lt.ymin) yp2(i)=yp2(i)+ymax-ymin
+ if (yp2(i).gt.ymax) yp2(i)=yp2(i)-ymax+ymin
+ if (zp2(i).lt.zmin) zp2(i)=zp2(i)+zmax-zmin
+ if (zp2(i).gt.zmax) zp2(i)=zp2(i)-zmax+zmin
+ enddo
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+c call interho_cic(npart2,vx2,vy2,vz2,xp2,yp2,zp2,nx3)
+ do i=1,npart2
+ xp2(i)=xp20(i)
+ yp2(i)=yp20(i)
+ zp2(i)=zp20(i)+delt3*vz2(i)
+ if (zp2(i).lt.zmin) zp2(i)=zp2(i)+zmax-zmin
+ if (zp2(i).gt.zmax) zp2(i)=zp2(i)-zmax+zmin
+ enddo
+
+ call remesh_rhoz(npart2,circlim,phip,
+ 1 xp2,yp2,zp2)
+
+ print*,' npart RHO apres remeshing ', kk,npart2
+c si on met dif_rho, on peut mettre en commentaire la boucle
+c d'assignement a la fin de remesh_rhoz ..
+ call dif_rho(npart2,circlim,phip,
+ 1 xp2,yp2,zp2,anu_rho,delt3,coef_les,rhomax)
+
+c Fin de push / remesh rho /dif rho
+ call veloxaux(nx3,vmax)
+ delt=.25/abs(omax)
+ delt3=0.5*dx3/vmax
+c delt3=delt
+ print*, ' Pas de temps omega et rho ', delt,delt3
+ k_delt3=max(1,int(delt3/delt))
+ delt3=float(k_delt3)*delt
+ ic=0
+ endif
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep,npart2, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+c go to 333
+
+ write(20) (((rhog(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+
+
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+ open(2,file='part1.fin')
+ nn=nx1/2+1
+ do i=1,nx
+ xx=(i-1)*dx
+ write(2,*) xx,rhog(10,i,2)
+ enddo
+ close(2)
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_small.f b/CodesEnVrac/CodeGH/main/main_small.f
new file mode 100644
index 0000000000000000000000000000000000000000..a757278e8ed193c03d69df1d662d33ad14a88c8e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_small.f
@@ -0,0 +1,171 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+
+ circlim=-1.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=1
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.14
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=128
+ dx3=xmax/float(nx3)
+ ic=0
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ call readfield(rhomax,vmax,dvmax)
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ print*,'VMAX et DV MX ',vmax,dvmax/dx3
+c delt3=0.0036
+c delt3=0.0144
+ delt3=1.
+ if (dvmax.ne.0.) delt3=amin1(delt3,0.25*dx3/dvmax)
+ print*, ' ITE, TIME, Pas de temps ', kk,time,delt3
+ print*, 'CFL1 CFL2 et LCFL ',
+ 1 vmax*delt3/dx3,vmax*delt3/dx2,dvmax*delt3/dx3
+ print*,' Worstcase: LCF=2 x CFL1 = 1/2 CFL2'
+c cfl=0.4
+c delt3=cfl*dx3/2.
+c delt3=0.2*dx3/dvmax
+
+ dt=delt3
+ np_bl=3
+ nx=nx2
+ dx=dx2
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ if (kk.eq.nit) then
+
+ open(20,file='rho_bin',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ open(24,file='rho_asci')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(24)
+ endif
+ print*,'**** time, RHO MAX = ',time,umax
+
+223 continue
+
+
+ time=time+dt
+20 continue
+
+
+202 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_small_nosplit.f b/CodesEnVrac/CodeGH/main/main_small_nosplit.f
new file mode 100644
index 0000000000000000000000000000000000000000..2d28ed554dcaa2436bfe1e704800d0870b761404
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_small_nosplit.f
@@ -0,0 +1,201 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+
+ circlim=-1.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.14
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=128
+ dx3=xmax/float(nx3)
+ ic=0
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ call readfield(rhomax,vmax,dvmax)
+
+ npart2=0
+ do k=1,nz2
+ do j=1,ny2
+ do i=1,nx2
+ if (ug(i,j,k).gt.0.0001) then
+ npart2=npart2+1
+ xp2(npart2)=x0+float(i-1)*dx2
+ yp2(npart2)=y0+float(j-1)*dx2
+ zp2(npart2)=z0+float(k-1)*dx2
+ phip(npart2)=ug(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+c call veloxaux(vmax,dvmax)
+ print*,'VMAX et DV MX ',vmax,dvmax/dx3
+ delt3=0.0036
+c delt3=0.0144
+c if (dvmax.ne.0.) delt3=amin1(delt3,0.2*dx3/dvmax)
+ print*, ' ITE, TIME, Pas de temps ', kk,time,delt3
+ print*, 'CFL1 CFL2 et LCFL ',
+ 1 vmax*delt3/dx3,vmax*delt3/dx2,dvmax*delt3/dx3
+ print*,' Worstcase: LCF=2 x CFL1 = 1/2 CFL2'
+
+ dt=delt3
+ np_bl=1
+ nx=nx2
+ dx=dx2
+
+c RK 2 pour advection particules xp2
+
+ call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2)
+ do i=1,npart2
+ xp20(i)=xp2(i)
+ yp20(i)=yp2(i)
+ zp20(i)=zp2(i)
+ xp2(i)=xp2(i)+0.5*dt*vx2(i)
+ yp2(i)=yp2(i)+0.5*dt*vy2(i)
+ zp2(i)=zp2(i)+0.5*dt*vz2(i)
+ enddo
+c call interho(npart2,vx2,vy2,vz2,xp2,yp2,zp2)
+ do i=1,npart2
+ xp2(i)=xp20(i)+dt*vx2(i)
+ yp2(i)=yp20(i)+dt*vy2(i)
+ zp2(i)=zp20(i)+dt*vz2(i)
+ enddo
+
+c remesh tensoriel
+ circlim=0.0001
+ call remesh_rho(npart2,phip,
+ 1 xp2,yp2,zp2)
+
+c diffusion
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+
+ open(20,file='rho_bin',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ open(24,file='rho_asci')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+
+20 continue
+
+
+202 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_small_split.f b/CodesEnVrac/CodeGH/main/main_small_split.f
new file mode 100644
index 0000000000000000000000000000000000000000..39ab09772a09546b0cbe2bb186fb78934a612bd0
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_small_split.f
@@ -0,0 +1,165 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+
+ circlim=-1.
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=0.14
+ t2=1.4
+c t3=0.784
+c t4=1.13
+ t3=1000.
+ t4=1000.
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=128
+ dx3=xmax/float(nx3)
+ ic=0
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ call readfield(rhomax,vmax,dvmax)
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+c call veloxaux(vmax,dvmax)
+ print*,'VMAX et DV MX ',vmax,dvmax/dx3
+ delt3=0.0036
+ delt3=0.0144
+ if (dvmax.ne.0.) delt3=amin1(delt3,0.2*dx3/dvmax)
+ print*, ' ITE, TIME, Pas de temps ', kk,time,delt3
+ print*, 'CFL1 CFL2 et LCFL ',
+ 1 vmax*delt3/dx3,vmax*delt3/dx2,dvmax*delt3/dx3
+ print*,' Worstcase: LCF=2 x CFL1 = 1/2 CFL2'
+
+ dt=delt3
+ np_bl=1
+ nx=nx2
+ dx=dx2
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+
+ open(20,file='rho_bin',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ open(24,file='rho_asci')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+
+20 continue
+
+
+202 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/main/main_test.f b/CodesEnVrac/CodeGH/main/main_test.f
new file mode 100644
index 0000000000000000000000000000000000000000..aefd98bcbc182e9051817cf5bf7fcabe4be994fe
--- /dev/null
+++ b/CodesEnVrac/CodeGH/main/main_test.f
@@ -0,0 +1,184 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c nx3=128
+ dx3=xmax/float(nx3)
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.003
+ delt=delt0
+ delt3=delt
+
+ call readfield(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+ call velox
+ call veloxaux(vmax,dvmax)
+ dvmax=0.
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*,' LCFL = ',dvmax*delt3/dx3
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ circlim=+0.0001
+ dt=delt3
+c dt=0.
+ np_bl=2
+ nx=nx2
+ dx=dx2
+ call x_advect(dt,np_bl)
+ call y_advect(dt,np_bl)
+ call z_advect(dt,np_bl)
+
+ call dif_rho(anu_rho,dt)
+ umax=0.
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** TIME et RHO MAX = ',time,umax
+
+
+c Fin de push / remesh rho /dif rho
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+202 continue
+
+
+ write(filerho,140)istep
+140 format('rho',i1)
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/C_IN.DAT b/CodesEnVrac/CodeGH/src-THI/C_IN.DAT
new file mode 100644
index 0000000000000000000000000000000000000000..979c75699aca7978be7c7c0b75a53fdee07f4823
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/C_IN.DAT
@@ -0,0 +1,16 @@
+-nombre de points pour flow
+128
+-nombre de points pour traceurs
+128
+-n1 d'iterations
+10000
+- viscosite
+0.001
+- Prandtl
+0.0001
+- coef les
+0.0
+- ordre du splitting
+1
+- tstop
+0.1
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/bin2asc.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/bin2asc.f
new file mode 100644
index 0000000000000000000000000000000000000000..05887bc933560234ef9e174f6c1d9ac48ec0e619
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/bin2asc.f
@@ -0,0 +1,49 @@
+ program bin2asc
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ dx=1./float(nx2)
+
+ rhomax=0.
+ open(20,file='rho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,nx2),k=1,nx2)
+
+ close(20)
+
+ open(24,file='rho.vtk')
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ rhomax=amax1(rhomax,abs(ug(i,j,k)))
+ write(24,*) ug(i,j,k)
+ enddo
+ enddo
+ enddo
+ print*,'rhonax',rhomax
+
+
+ stop
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/dfftw3d.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/dfftw3d.f
new file mode 100644
index 0000000000000000000000000000000000000000..4d69b0a1d2f6392d0f4fa41e3ae59bccd4afa7ec
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/dfftw3d.f
@@ -0,0 +1,151 @@
+ subroutine fftw3d(r,c,nx,ny,nz,nxs2,nys2,nzs2,wk,irc)
+
+c
+c Ce programme calcul la transformee de fourier rapide
+c
+C----------------------------------------------------------------------
+C TRANSFORMATION DE FOURIER REELLE<--->COMPLEXE TRI-DIMENSIONNELLE
+C X : VECTEUR REEL DE DIMENSION (nx,ny,nz)
+C C : VECTEUR COMPLEXE DE DIMENSION (0:nx/2,-ny/2+1:ny/2,-nz/2+1:nz/2)
+C WK : Vecteur de travail pour les fftw de dimension (0:nx/2,0:ny-1,0:nz-1)
+C IRC : =0: REELLE ---> COMPLEXE (X-->C) Directe
+C <>0: COMPLEXE ---> REELLE (C-->X) inverse
+C
+C REMARQUE:
+C CALCULE LA TRANSFORMATION SUIVANTE:
+C
+C X(J,K,L) J(1..nx),K(1..ny),L(1..Nz) <---> C(J,K,L) J=0..nx/2 K=-ny/2+1,...,ny/2,
+C L=-nz/2+1,...,nz/2
+C
+C----------------------------------------------------------------------
+c
+c Declaration pour utiliser les routines fftw
+c
+c This file contains PARAMETER statements for various constants
+c that can be passed to FFTW routines. You should include
+c this file in any FORTRAN program that calls the fftw_f77
+c routines (either directly or with an #include statement
+c if you use the C preprocessor).
+c
+
+ include '/opt/Softs/fftw/fftw-3.2.2-intel/include/fftw3.f'
+
+c INTEGER FFTW_FORWARD,FFTW_BACKWARD
+c PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+c
+c INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+c PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+c
+c INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+c PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+ccc
+c INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+c PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
+c
+ integer plan,nx,ny,nz,nxs2,nys2,nzs2,irc,i,j,k
+c
+ complex c,wk
+ dimension c(0:nxs2,1-nys2:nys2,1-nzs2:nzs2),wk(nxs2+1,ny,nz)
+c
+ real r
+ dimension r(nx,ny,nz)
+c
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=cmplx(0.0,0.0)
+ enddo
+ enddo
+ enddo
+c
+ plan=0
+ if (irc.eq.0) then
+
+ call dfftw_plan_dft_r2c_3d(plan,nx,ny,nz,r,wk,
+ 1 FFTW_ESTIMATE)
+ call dfftw_execute(plan)
+ call dfftw_destroy_plan(plan)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=wk(i,j,k)/nx/ny/nz
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-1)=wk(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-1)=wk(i,j+nys2+1,k)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-nzs2)=wk(i,j,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-nzs2)=wk(i,j+nys2+1,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+c
+ else
+c
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k)=c(i-1,j-1,k-1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k)=c(i-1,j-nys2,k-1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k+nzs2+1)=c(i-1,j-1,k-nzs2)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k+nzs2+1)=c(i-1,j-nys2,k-nzs2)
+ enddo
+ enddo
+ enddo
+c
+ call dfftw_plan_dft_c2r_3d(plan,nx,ny,nz,wk,r,
+ 1 FFTW_ESTIMATE)
+ call dfftw_execute(plan)
+ call dfftw_destroy_plan(plan)
+
+ endif
+c
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/filter_rho.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/filter_rho.f
new file mode 100644
index 0000000000000000000000000000000000000000..8caf193c84fb6cb699d79d0c34a7113818fdcaa4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/filter_rho.f
@@ -0,0 +1,128 @@
+ program spec
+
+
+ include 'param_rho.i'
+ include 'param.h'
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ parameter(npg2=256)
+ parameter(npgb2=npg2/2)
+
+ dimension rhog(npgx,npgy,npgz)
+ dimension ug(npg2,npg2,npg2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+ real ijc(1-ngx2:ngx2,1-ngx2:ngx2,1-ngx2:ngx2)
+ real nrj(ngx2)
+
+ complex cvx,wk2
+ dimension cvx(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2)
+ dimension wk2(npgb2+1,npg2,npg2)
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ nx3=256
+
+ ny2=nx2
+ nz2=nx2
+
+ nxb=nx2/2
+ nyb=ny2/2
+ nzb=nz2/2
+
+ nxb2=nx3/2
+ nyb2=nx3/2
+ nzb2=nx3/2
+
+ open(20,file='rho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ read(20) (((rhog(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ close(20)
+
+ print*,' Lecture finie '
+
+ call fftw3d(rhog,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,0)
+
+ do 10 k=1-nzb2,nzb2
+ do 10 j=1-nyb2,nyb2
+ do 10 i=0,nxb2
+ cvx(i,j,k)=cux(i,j,k)
+10 continue
+
+ call fftw3d(ug,cvx,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+
+ open(24,file='half_rho')
+
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx3," ",nx3," ",nx3
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",1./nx3," ",1./nx3," ",1./nx3
+ WRITE(24,*) "POINT_DATA ",nx3*nx3*nx3
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+
+
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ cfx(0,j,k)=cux(0,j,k)
+ do i=1,nxb
+ if (i.le.nxb-1) cfx(-i,j,k)=cux(i,j,k)
+ cfx(i,j,k)=cux(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ print*,' sort de fft '
+
+ open(1,file='spectre')
+
+ s=0.
+ do l=1,nxb2
+c
+ do k=1-nzb2-2,nzb2+2
+ do j=1-nyb2-2,nyb2+2
+ do i=1-nxb2-2,nxb2+2
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ xmod=sqrt(ijc(i,j,k))
+ if ((xmod.lt.l+0.5).and.(xmod.ge.l-0.5)) then
+ z=cabs(cfx(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ print*, 'L =',l
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+
+c filter at half-size
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/init.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/init.f
new file mode 100644
index 0000000000000000000000000000000000000000..b6196f8b758201a0cd6868d1f25c1cf89cce8db7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/init.f
@@ -0,0 +1,90 @@
+ subroutine readfield(rhomax,vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ real*8 tout(npgx,npgy,npgz,4)
+
+ rhomax=0.
+
+ open(20,file='datarho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ close(20)
+
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ ug(i,j,k)=1.
+ rhomax=amax1(umax,abs(ug(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+! goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi1(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi2(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi3(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+ vmax=amax1(umax1,umax2,umax3)
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+111 continue
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/init_bubble.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/init_bubble.f
new file mode 100644
index 0000000000000000000000000000000000000000..866b448d8250fbb8ae388b90f13a944ce796c699
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/init_bubble.f
@@ -0,0 +1,73 @@
+ subroutine bubble(npart,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension omx(*),omy(*),omz(*)
+
+ pi=3.1415926
+ pi2=2.*pi
+ circ=0.
+ x0=0.
+ y0=0.
+ z0=0.
+
+ npart=0
+ do i=1,nx1
+ do j=1,ny1
+ do k=1,nz1
+ xx=(float(i)-1.)*dx1
+ yy=(float(j)-1.)*dx1
+ zz=(float(k)-1.)*dx1
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+ strg1(i,j,k)=0.
+ strg2(i,j,k)=0.
+ strg3(i,j,k)=0.
+ vxg(i,j,k)=0.
+ vyg(i,j,k)=0.
+ vzg(i,j,k)=0.
+ npart=npart+1
+ xp1(npart)=xx
+ yp1(npart)=yy
+ zp1(npart)=zz
+ dv1(npart)=dx1*dx1*dx1
+ omx(npart)=0.
+ omy(npart)=0.
+ omz(npart)=0.
+ enddo
+ enddo
+ enddo
+
+ tm=0.
+ do k=1,nz2
+ do j=1,ny2
+ do i=1,nx2
+ ug(i,j,k)=0.
+ yy=abs(float(j-1)*dx2-0.5)
+ xx1=abs(float(i-1)*dx2-0.15)
+ xx2=abs(float(i-1)*dx2-0.45)
+ zz=abs(float(k-1)*dx2-0.5)
+ rr1=sqrt(xx1*xx1+yy*yy+zz*zz)
+ rr2=sqrt(xx2*xx2+yy*yy+zz*zz)
+ rr3=sqrt(xx2*xx2+yy*yy)
+! if ((rr1.le.0.1).or.(rr2.lt.0.15)) then
+ if ((rr3.le.0.25)) then
+! if ((xx2.le.0.15).and.(yy.lt.0.15).and.(zz.le.0.15)) then
+ ug(i,j,k)=1.+0.05*(strg1(i,j,k)-0.5)
+ ug(i,j,k)=1.
+ endif
+ tm=tm+ug(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ print*, ' MASSE SCALAIRE a init ',tm*dx2*dx2*dx2
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/init_burgers.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/init_burgers.f
new file mode 100644
index 0000000000000000000000000000000000000000..eed7be66bf34f6dfbbe6da9d22218de871bf054b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/init_burgers.f
@@ -0,0 +1,27 @@
+ subroutine init_burgers
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ umax=0.
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ ug(i,j,k)=0.
+c if ((j.eq.nx2/2).and.(k.eq.nx2/2)) then
+ if ((j.lt.9).and.(k.lt.9)) then
+ xx=xmin+(i-1)*dx2
+ ug(i,j,k)=1.
+ if (xx.gt.0.5*(xmin+xmax)) ug(i,j,k)=-1.
+ endif
+ umax=amax1(umax,abs(ug(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'UMAX a init', umax
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_GB.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_GB.f
new file mode 100644
index 0000000000000000000000000000000000000000..bbe9a751fde68a382651a589c66ec06a28df510d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_GB.f
@@ -0,0 +1,48 @@
+ subroutine readfield(rhomax,vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ real*8 vel(32,32,32,3)
+ real*8 dens(128,128,128)
+
+ open(2,file='GB/data2read',form='binary',
+ 1 status='unknown')
+ read(2) buf1,buf2,buf3,buf4
+ read(2) ((((vel(i,j,k,l),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3),l=1,3)
+ read(2) (((dens(i,j,k),
+ 1 i=1,nx2),j=1,nx2),k=1,nx2)
+
+
+ vmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ vxg(i,j,k)=vel(i,j,k,1)
+ vyg(i,j,k)=vel(i,j,k,2)
+ vzg(i,j,k)=vel(i,j,k,3)
+ vmax=amax1(vmax,abs(vxg(i,j,k)))
+ vmax=amax1(vmax,abs(vyg(i,j,k)))
+ vmax=amax1(vmax,abs(vzg(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ rhomax=0.
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ ug(i,j,k)=dens(i,j,k)
+ rhomax=amax1(rhomax,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+
+ print*,' rhomax a init = ',rhomax
+ print*,' vmax a init = ',vmax
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_full.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_full.f
new file mode 100644
index 0000000000000000000000000000000000000000..9d40311748bbe447c63d2e3ad449cab54582cdea
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_full.f
@@ -0,0 +1,78 @@
+ subroutine readfield(npart,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ real*8 tout(npgx,npgy,npgz,4)
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension omx(*),omy(*),omz(*)
+
+ pi=3.1415926
+ pi2=2.*pi
+ circ=0.
+ x0=0.
+ y0=0.
+ z0=0.
+
+ open(2,file='datax',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file='datay',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file='dataz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(20,file='datarho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ read(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ read(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ read(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ close(2)
+ close(3)
+ close(4)
+ close(20)
+
+ npart=0
+ rhomax=0.
+ do 10 i=1,nx1
+ xx=(float(i)-1.)*dx1
+ do 10 j=1,ny1
+ yy=(float(j)-1.)*dx1
+ do 10 k=1,nz1
+ zz=(float(k)-1.)*dx1
+ aux1=omg1(i,j,k)
+ aux2=omg2(i,j,k)
+ aux3=omg3(i,j,k)
+ if (abs(aux1)+abs(aux2)+abs(aux3).gt.0.0001) then
+ npart=npart+1
+ xp1(npart)=xx
+ yp1(npart)=yy
+ zp1(npart)=zz
+ dv1(npart)=dx1*dx1*dx1
+ omx(npart)=dv1(npart)*aux1
+ omy(npart)=dv1(npart)*aux2
+ omz(npart)=dv1(npart)*aux3
+ circ=circ+omz(npart)
+ rhomax=amax1(rhomax,ug(i,j,k))
+ endif
+10 continue
+ print*, 'NPART ROMAX t=0 =', npart,rhomax
+
+! initailisation des particules de densite et de leurs pentes
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_small.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_small.f
new file mode 100644
index 0000000000000000000000000000000000000000..b6196f8b758201a0cd6868d1f25c1cf89cce8db7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/initread_small.f
@@ -0,0 +1,90 @@
+ subroutine readfield(rhomax,vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ real*8 tout(npgx,npgy,npgz,4)
+
+ rhomax=0.
+
+ open(20,file='datarho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ close(20)
+
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ ug(i,j,k)=1.
+ rhomax=amax1(umax,abs(ug(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+! goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi1(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi2(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi3(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+ vmax=amax1(umax1,umax2,umax3)
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+111 continue
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_cic.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_cic.f
new file mode 100644
index 0000000000000000000000000000000000000000..a82f256379995059e0cb326bbf45ed332fefb029
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_cic.f
@@ -0,0 +1,149 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE interho(npart,g1,g2,g3,xp,yp,zp)
+
+C
+C Interpolation routine with M'4
+C
+! geometry=unit box, periodic in x and y
+! last ponits in z direction assume extension by continuity
+! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),rhog(npg,npg,npg)
+
+
+ do 10 i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+ dyinv=1./dy3
+ dzinv=1./dz3
+ dh3=dx3*dy3*dz3
+ dhinv3=1./dh3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ yy1 = (y - float(jp1)*dy3-y0)*dyinv
+ zz1 = (z - float(kp1)*dz3-z0)*dzinv
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+C
+C on repositionne les points de grille par periodicite
+! entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+
+
+ jp1=mod(jp1+ny3,ny3) +1
+ jp2=mod(jp2+ny3,ny3) +1
+
+ kp1=mod(kp1+nz3,nz3) +1
+ kp2=mod(kp2+nz3,nz3) +1
+
+C
+C The M'4 scheme
+C
+
+ a1 = xx2
+ b1 = yy2
+ c1 = zz2
+
+ a2 = xx1
+ b2 = yy1
+ c2 = zz1
+
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+
+ g2(i)= g2(i) + gg2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + gg2(ip1,jp2,kp1)*a1*b2*c1
+
+ g3(i)= g3(i) + gg3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + gg3(ip1,jp2,kp1)*a1*b2*c1
+c
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+
+ g2(i)= g2(i) + gg2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + gg2(ip2,jp2,kp1)*a2*b2*c1
+
+ g3(i)= g3(i) + gg3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + gg3(ip2,jp2,kp1)*a2*b2*c1
+c
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+
+ g2(i)= g2(i) + gg2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + gg2(ip1,jp2,kp2)*a1*b2*c2
+
+ g3(i)= g3(i) + gg3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + gg3(ip1,jp2,kp2)*a1*b2*c2
+c
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+ g2(i)= g2(i) + gg2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + gg2(ip2,jp2,kp2)*a2*b2*c2
+
+ g3(i)= g3(i) + gg3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + gg3(ip2,jp2,kp2)*a2*b2*c2
+c
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_m4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_m4.f
new file mode 100644
index 0000000000000000000000000000000000000000..e2f622a2ddeba2ab986ccc263a5a84d58ad0c123
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/interho_m4.f
@@ -0,0 +1,165 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE interho(npart,g1,g2,g3,xp,yp,zp)
+
+C
+C Interpolation routine with M'4
+C
+! geometry=unit box, periodic in x and y
+! last ponits in z direction assume extension by continuity
+! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),rhog(npg,npg,npg)
+
+
+ do 10 i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+ dyinv=1./dy3
+ dzinv=1./dz3
+ dh3=dx3*dy3*dz3
+ dhinv3=1./dh3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ yy1 = (y - float(jp1)*dy3-y0)*dyinv
+ zz1 = (z - float(kp1)*dz3-z0)*dzinv
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+ xx3=2-xx1
+ yy3=2-yy1
+ zz3=2-zz1
+
+C
+C on repositionne les points de grille par periodicite
+! entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+ ip3=mod(ip3+nx3,nx3) +1
+
+
+ jp1=mod(jp1+ny3,ny3) +1
+ jp2=mod(jp2+ny3,ny3) +1
+ jp3=mod(jp3+ny3,ny3) +1
+
+ kp1=mod(kp1+nz3,nz3) +1
+ kp2=mod(kp2+nz3,nz3) +1
+ kp3=mod(kp3+nz3,nz3) +1
+
+C
+C The M'4 scheme
+C
+
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp0)*a0*b0*c0
+ g1(i)= g1(i) + GG1(ip0,jp1,kp0)*a0*b1*c0
+ g1(i)= g1(i) + GG1(ip0,jp2,kp0)*a0*b2*c0
+ g1(i)= g1(i) + GG1(ip0,jp3,kp0)*a0*b3*c0
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp0)*a0*b0*c0
+ g2(i)= g2(i) + GG2(ip0,jp1,kp0)*a0*b1*c0
+ g2(i)= g2(i) + GG2(ip0,jp2,kp0)*a0*b2*c0
+ g2(i)= g2(i) + GG2(ip0,jp3,kp0)*a0*b3*c0
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp0)*a0*b0*c0
+ g3(i)= g3(i) + GG3(ip0,jp1,kp0)*a0*b1*c0
+ g3(i)= g3(i) + GG3(ip0,jp2,kp0)*a0*b2*c0
+ g3(i)= g3(i) + GG3(ip0,jp3,kp0)*a0*b3*c0
+c
+ g1(i)= g1(i) + GG1(ip1,jp0,kp0)*a1*b0*c0
+ g1(i)= g1(i) + GG1(ip1,jp1,kp0)*a1*b1*c0
+ g1(i)= g1(i) + GG1(ip1,jp2,kp0)*a1*b2*c0
+ g1(i)= g1(i) + GG1(ip1,jp3,kp0)*a1*b3*c0
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp0)*a1*b0*c0
+ g2(i)= g2(i) + GG2(ip1,jp1,kp0)*a1*b1*c0
+ g2(i)= g2(i) + GG2(ip1,jp2,kp0)*a1*b2*c0
+ g2(i)= g2(i) + GG2(ip1,jp3,kp0)*a1*b3*c0
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp0)*a1*b0*c0
+ g3(i)= g3(i) + GG3(ip1,jp1,kp0)*a1*b1*c0
+ g3(i)= g3(i) + GG3(ip1,jp2,kp0)*a1*b2*c0
+ g3(i)= g3(i) + GG3(ip1,jp3,kp0)*a1*b3*c0
+c
+ g1(i)= g1(i) + GG1(ip2,jp0,kp0)*a2*b0*c0
+ g1(i)= g1(i) + GG1(ip2,jp1,kp0)*a2*b1*c0
+ g1(i)= g1(i) + GG1(ip2,jp2,kp0)*a2*b2*c0
+ g1(i)= g1(i) + GG1(ip2,jp3,kp0)*a2*b3*c0
+:wq
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers
new file mode 100644
index 0000000000000000000000000000000000000000..625c7734660a8430ff0fda54f65fbe89c9006c3b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers
@@ -0,0 +1,53 @@
+#
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = burgers
+
+OBJSF = init_burgers.o\
+ main_burgers.o \
+ velox_burgers.o \
+ remeshx_l2_limit.o \
+ remeshx_tag_limit.o \
+ tag_particles_limit.o \
+ x_advect_corec_limit.o \
+ velox_x.o \
+ slopes.o \
+ fftw3d.o
+
+init_burgers.o: init_burgers.f param.i
+ ifort $(OPT3) -c init_burgers.f
+main_burgers.o: main_burgers.f param.i
+ ifort $(OPT3) -c main_burgers.f
+velox_burgers.o: velox_burgers.f param.i
+ ifort $(OPT3) -c velox_burgers.f
+slopes.o: slopes.f param.i
+ ifort $(OPT3) -c slopes.f
+x_advect_corec_limit.o: x_advect_corec_limit.f param.i
+ ifort $(OPT3) -c x_advect_corec_limit.f
+remeshx_l2_limit.o: remeshx_l2_limit.f param.i
+ ifort $(OPT3) -c remeshx_l2_limit.f
+remeshx_tag_limit.o: remeshx_tag_limit.f param.i
+ ifort $(OPT3) -c remeshx_tag_limit.f
+tag_particles_limit.o: tag_particles_limit.f param.i
+ ifort $(OPT3) -c tag_particles_limit.f
+velox_x.o: velox_x.f param.i
+ ifort $(OPT3) -c velox_x.f
+
+$(PROGRAM): $(OBJSF)
+ ifort $(OPT3) $(OBJSF) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers_nolimit b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers_nolimit
new file mode 100644
index 0000000000000000000000000000000000000000..b4abb2cb7ede966023fec3395be93a54738d82e5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_burgers_nolimit
@@ -0,0 +1,44 @@
+#
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = burgers
+
+OBJSF = init_burgers.o\
+ main_burgers.o \
+ velox_burgers.o \
+ remeshx_l2.o \
+ x_advect_orig.o \
+ velox_x.o \
+ fftw3d.o
+
+init_burgers.o: init_burgers.f param.i
+ ifort $(OPT3) -c init_burgers.f
+main_burgers.o: main_burgers.f param.i
+ ifort $(OPT3) -c main_burgers.f
+velox_burgers.o: velox_burgers.f param.i
+ ifort $(OPT3) -c velox_burgers.f
+x_advect_orig.o: x_advect_orig.f param.i
+ ifort $(OPT3) -c x_advect_orig.f
+remeshx_l2.o: remeshx_l2.f param.i
+ ifort $(OPT3) -c remeshx_l2.f
+velox_x.o: velox_x.f param.i
+ ifort $(OPT3) -c velox_x.f
+
+$(PROGRAM): $(OBJSF)
+ ifort $(OPT3) $(OBJSF) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb
new file mode 100644
index 0000000000000000000000000000000000000000..d82b8c194409bc1272fba3989025499549a8956d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb
@@ -0,0 +1,112 @@
+#
+# la commande f77 pour les dec est f77_520
+#
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = freeb
+
+all: $(PROGRAM)
+
+OBJSF = diag.o\
+ init_bubble.o \
+ intervm4.o \
+ intersm4.o \
+ interho.o \
+ main_freeb.o \
+ dif.o \
+ dif_rho.o \
+ remesh_om.o \
+ remesh_rho.o \
+ remeshx_l4.o \
+ remeshy_l4.o \
+ remeshz_l4.o \
+ remeshx_l4_tag.o \
+ remeshy_l4_tag.o \
+ remeshz_l4_tag.o \
+ tag_particles_l4.o \
+ x_advect_l4.o \
+ y_advect_l4.o \
+ z_advect_l4.o \
+ stretch_freeb.o \
+ fftw3d.o \
+ velox_x.o \
+ velox_y.o \
+ velox_z.o \
+ veloxaux.o \
+ stension.o \
+ velox.o
+
+diag.o: diag.f param.i
+ ifort $(OPT3) -c diag.f
+dif.o: dif.f param.i
+ ifort $(OPT3) -c dif.f
+dif_rho.o: dif_rho.f param.i
+ ifort $(OPT3) -c dif_rho.f
+init_bubble.o: init_bubble.f param.i
+ ifort $(OPT3) -c -g init_bubble.f
+intervm4.o: intervm4.f param.i
+ ifort $(OPT3) -c intervm4.f
+intersm4.o: intersm4.f param.i
+ ifort $(OPT3) -c intersm4.f
+interho.o: interho.f param.i
+ ifort $(OPT3) -c interho.f
+main_freeb.o: main_freeb.f param.i
+ ifort $(OPT3) -c -g main_freeb.f
+remesh_om.o: remesh_om.f param.i
+ ifort $(OPT3) -c remesh_om.f
+remesh_rho.o: remesh_rho.f param.i
+ ifort $(OPT3) -c remesh_rho.f
+remeshx_l4.o: remeshx.f param.i
+ ifort $(OPT3) -c remeshx_l4.f
+remeshy_l4.o: remeshy.f param.i
+ ifort $(OPT3) -c remeshy_l4.f
+remeshz_l4.o: remeshz.f param.i
+ ifort $(OPT3) -c remeshz_l4.f
+remeshx_l4_tag.o: remeshx_tag.f param.i
+ ifort $(OPT3) -c remeshx_l4_tag.f
+remeshy_l4_tag.o: remeshy_tag.f param.i
+ ifort $(OPT3) -c remeshy_l4_tag.f
+remeshz_l4_tag.o: remeshz_tag.f param.i
+ ifort $(OPT3) -c remeshz_l4_tag.f
+x_advect_l4.o: x_advect_l4.f param.i
+ ifort $(OPT3) -c x_advect_l4.f
+y_advect_l4.o: y_advect_l4.f param.i
+ ifort $(OPT3) -c y_advect_l4.f
+z_advect_l4.o: z_advect_l4.f param.i
+ ifort $(OPT3) -c z_advect_l4.f
+tag_particles_l4.o: tag_particles_l4.f param.i
+ ifort $(OPT3) -c tag_particles_l4.f
+stretch_freeb.o: stretch_freeb.f param.i
+ ifort $(OPT3) -c stretch_freeb.f
+velox.o: velox.f param.i
+ ifort $(OPT3) -c velox.f
+velox_x.o: velox_x.f param.i
+ ifort $(OPT3) -c velox_x.f
+velox_y.o: velox_y.f param.i
+ ifort $(OPT3) -c velox_y.f
+velox_z.o: velox_z.f param.i
+ ifort $(OPT3) -c velox_z.f
+veloxaux.o: veloxaux.f param.i
+ ifort $(OPT3) -c veloxaux.f
+stension.o: stension.f param.i
+ ifort $(OPT3) -c stension.f
+fftw3d.o: fftw3d.f param.i
+ ifort $(OPT3) -c fftw3d.f
+
+
+$(PROGRAM): $(OBJSF)
+ ifort $(OPT3) $(OBJSF) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb_small b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb_small
new file mode 100644
index 0000000000000000000000000000000000000000..5ee412184dffd2e1b282ea8828bc8c3727e628e3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_freeb_small
@@ -0,0 +1,38 @@
+#
+# la commande f77 pour les dec est f77_520
+#
+FF =ifort
+
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = freeb
+
+all: $(PROGRAM)
+
+OBJ = init_bubble.o\
+ main_freeb_small.o \
+ fftw3d.o \
+ veloxaux.o \
+ stension_fourier.o \
+ velox.o
+
+%.o: %.f param.i arrays.h
+ $(FF) -o $@ -c $< $(OPT3)
+
+$(PROGRAM): $(OBJ)
+ ifort $(OPT3) $(OBJ) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_l4 b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_l4
new file mode 100644
index 0000000000000000000000000000000000000000..9030608bc9e0379843dc588dea7b2bd7c14eac4e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/makefile_l4
@@ -0,0 +1,112 @@
+#
+# la commande f77 pour les dec est f77_520
+#
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = thi_l4
+
+all: $(PROGRAM)
+
+OBJSF = diag.o\
+ initread.o \
+ initjet.o \
+ intervm4.o \
+ intersm4.o \
+ interho.o \
+ main.o \
+ dif.o \
+ dif_rho.o \
+ remesh_om.o \
+ remesh_rho.o \
+ remeshx_l4.o \
+ remeshy_l4.o \
+ remeshz_l4.o \
+ remeshx_l4_tag.o \
+ remeshy_l4_tag.o \
+ remeshz_l4_tag.o \
+ tag_particles_l4.o \
+ x_advect_l4.o \
+ y_advect_l4.o \
+ z_advect_l4.o \
+ stretch.o \
+ fftw3d.o \
+ velox_x.o \
+ velox_y.o \
+ velox_z.o \
+ veloxaux.o \
+ velox.o
+
+diag.o: diag.f param.i
+ ifort $(OPT3) -c diag.f
+dif.o: dif.f param.i
+ ifort $(OPT3) -c dif.f
+dif_rho.o: dif_rho.f param.i
+ ifort $(OPT3) -c dif_rho.f
+initread.o: initread.f param.i
+ ifort $(OPT3) -c -g initread.f
+initjet.o: initjet.f param.i
+ ifort $(OPT3) -c -g initjet.f
+intervm4.o: intervm4.f param.i
+ ifort $(OPT3) -c intervm4.f
+intersm4.o: intersm4.f param.i
+ ifort $(OPT3) -c intersm4.f
+interho.o: interho.f param.i
+ ifort $(OPT3) -c interho.f
+main.o: main.f param.i
+ ifort $(OPT3) -c -g main.f
+remesh_om.o: remesh_om.f param.i
+ ifort $(OPT3) -c remesh_om.f
+remesh_rho.o: remesh_rho.f param.i
+ ifort $(OPT3) -c remesh_rho.f
+remeshx_l4.o: remeshx.f param.i
+ ifort $(OPT3) -c remeshx_l4.f
+remeshy_l4.o: remeshy.f param.i
+ ifort $(OPT3) -c remeshy_l4.f
+remeshz_l4.o: remeshz.f param.i
+ ifort $(OPT3) -c remeshz_l4.f
+remeshx_l4_tag.o: remeshx_tag.f param.i
+ ifort $(OPT3) -c remeshx_l4_tag.f
+remeshy_l4_tag.o: remeshy_tag.f param.i
+ ifort $(OPT3) -c remeshy_l4_tag.f
+remeshz_l4_tag.o: remeshz_tag.f param.i
+ ifort $(OPT3) -c remeshz_l4_tag.f
+x_advect_l4.o: x_advect_l4.f param.i
+ ifort $(OPT3) -c x_advect_l4.f
+y_advect_l4.o: y_advect_l4.f param.i
+ ifort $(OPT3) -c y_advect_l4.f
+z_advect_l4.o: z_advect_l4.f param.i
+ ifort $(OPT3) -c z_advect_l4.f
+tag_particles_l4.o: tag_particles_l4.f param.i
+ ifort $(OPT3) -c tag_particles_l4.f
+stretch.o: stretch.f param.i
+ ifort $(OPT3) -c stretch.f
+velox.o: velox.f param.i
+ ifort $(OPT3) -c velox.f
+velox_x.o: velox_x.f param.i
+ ifort $(OPT3) -c velox_x.f
+velox_y.o: velox_y.f param.i
+ ifort $(OPT3) -c velox_y.f
+velox_z.o: velox_z.f param.i
+ ifort $(OPT3) -c velox_z.f
+veloxaux.o: veloxaux.f param.i
+ ifort $(OPT3) -c veloxaux.f
+fftw3d.o: fftw3d.f param.i
+ ifort $(OPT3) -c fftw3d.f
+
+
+$(PROGRAM): $(OBJSF)
+ ifort $(OPT3) $(OBJSF) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..29cacbfe4e7497179681fab931f0cdf7b646fe11
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_l4_tag.f
@@ -0,0 +1,181 @@
+ subroutine remesh_tag(ntag,itag,itype,icfl)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dimension ug(npg),up(npg),xp(npg)
+
+ dx2=dh
+ dxinv=1./dh
+
+ do i=1,nx
+! ug(i)=0.
+ enddo
+
+ do n=1,ntag-1,4
+! do n=1,1
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! u1m=0.
+! u0=0.
+! u1p=2.
+! u2p=0.
+ tm=u1m+u0+u1p+u2p
+ print*, 'TM avant remshtag', tm
+ print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+ 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+ print*, 'xx1p ',xx1p
+! reperage des points de grille concernes
+c de I-4 a I+4 ou I est point de grille a gauche de particule x0
+ ip4m=ip0-4
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+ ip4m=mod(ip4m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ ug(ip4m)=ug(ip4m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(ip3m)=ug(ip3m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ ug(ip2m)=ug(ip2m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip1m)=ug(ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip0)=ug(ip0)+u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(ip1p)=ug(ip1p)+u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(ip2p)=ug(ip2p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(ip3p)=ug(ip3p)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip4p)=ug(ip4p)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+ print*,'c et d',n
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ ug(ip3m)=ug(ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(ip2m)=ug(ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ ug(ip1m)=ug(ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0+(xx0-1.)*(xx0+1.)*(xx0+2.)*(xx0+3)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(ip0)=ug(ip0)+u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=-(xx0-1.)*(xx0+1.)*(xx0+2.)*(xx0+3)/6.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(ip1p)=ug(ip1p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(ip2p)=ug(ip2p)+u1p*coef1p+u2p*coef2p
+
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip3p)=ug(ip3p)+u2p*coef2p
+c
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_rhom4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_rhom4.f
new file mode 100644
index 0000000000000000000000000000000000000000..89fa19ae2ac4237955f471a35b3d50e4de49601e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_rhom4.f
@@ -0,0 +1,379 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE remesh_rho(npart,phip,
+ 1 xp2,yp2,zp2)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp2(*),yp2(*),zp2(*)
+ dimension phip(*)
+
+
+ do 10 i=1,nx2
+ do 10 j=1,ny2
+ do 10 k=1,nz2
+ ug(i,j,k)=0.
+10 continue
+
+ dy2=dx2
+ dz2=dx2
+
+ dxinv=1./(dx2)
+ dyinv=dxinv
+ dzinv=dxinv
+
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=0.
+ y0=0.
+ z0=0.
+
+ vol=1.
+
+ DO 20 n = 1,npart
+
+ g1 = phip(n)/vol
+
+ x = xp2(n)
+ y = yp2(n)
+ z = zp2(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+C Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dy2-y0)*dyinv
+ zz1 = (z - float(kp1)*dz2-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+C
+C on repositionne les points de grille par periodicite
+! entre 0 et npx-1, puis on numerote de 1 a npx
+C
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+
+ jp1=mod(jp1+ny2,ny2) +1
+ jp0=mod(jp0+ny2,ny2) +1
+ jp2=mod(jp2+ny2,ny2) +1
+ jp3=mod(jp3+ny2,ny2) +1
+
+ kp1=mod(kp1+nz2,nz2) +1
+ kp0=mod(kp0+nz2,nz2) +1
+ kp2=mod(kp2+nz2,nz2) +1
+ kp3=mod(kp3+nz2,nz2) +1
+
+C The M'4 scheme
+C
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ coef=a0*b0*c0
+ ug(ip0,jp0,kp0) = ug(ip0,jp0,kp0) + g1*coef
+
+ coef=a0*b0*c1
+ ug(ip0,jp0,kp1) = ug(ip0,jp0,kp1) + g1*coef
+
+ coef=a0*b0*c2
+ ug(ip0,jp0,kp2) = ug(ip0,jp0,kp2) + g1*coef
+
+ coef=a0*b0*c3
+ ug(ip0,jp0,kp3) = ug(ip0,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b1*c0
+ ug(ip0,jp1,kp0) = ug(ip0,jp1,kp0) + g1*coef
+
+ coef=a0*b1*c1
+ ug(ip0,jp1,kp1) = ug(ip0,jp1,kp1) + g1*coef
+
+ coef=a0*b1*c2
+ ug(ip0,jp1,kp2) = ug(ip0,jp1,kp2) + g1*coef
+
+ coef=a0*b1*c3
+ ug(ip0,jp1,kp3) = ug(ip0,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b2*c0
+ ug(ip0,jp2,kp0) = ug(ip0,jp2,kp0) + g1*coef
+
+ coef=a0*b2*c1
+ ug(ip0,jp2,kp1) = ug(ip0,jp2,kp1) + g1*coef
+
+ coef=a0*b2*c2
+ ug(ip0,jp2,kp2) = ug(ip0,jp2,kp2) + g1*coef
+
+
+ coef=a0*b2*c3
+ ug(ip0,jp2,kp3) = ug(ip0,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b3*c0
+ ug(ip0,jp3,kp0) = ug(ip0,jp3,kp0) + g1*coef
+
+ coef=a0*b3*c1
+ ug(ip0,jp3,kp1) = ug(ip0,jp3,kp1) + g1*coef
+
+ coef=a0*b3*c2
+ ug(ip0,jp3,kp2) = ug(ip0,jp3,kp2) + g1*coef
+
+ coef=a0*b3*c3
+ ug(ip0,jp3,kp3) = ug(ip0,jp3,kp3) + g1*coef
+
+ccc
+ coef=a1*b0*c0
+ ug(ip1,jp0,kp0) = ug(ip1,jp0,kp0) + g1*coef
+
+ coef=a1*b0*c1
+ ug(ip1,jp0,kp1) = ug(ip1,jp0,kp1) + g1*coef
+
+ coef=a1*b0*c2
+ ug(ip1,jp0,kp2) = ug(ip1,jp0,kp2) + g1*coef
+
+ coef=a1*b0*c3
+ ug(ip1,jp0,kp3) = ug(ip1,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b1*c0
+ ug(ip1,jp1,kp0) = ug(ip1,jp1,kp0) + g1*coef
+
+ coef=a1*b1*c1
+ ug(ip1,jp1,kp1) = ug(ip1,jp1,kp1) + g1*coef
+
+ coef=a1*b1*c2
+ ug(ip1,jp1,kp2) = ug(ip1,jp1,kp2) + g1*coef
+
+ coef=a1*b1*c3
+ ug(ip1,jp1,kp3) = ug(ip1,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b2*c0
+ ug(ip1,jp2,kp0) = ug(ip1,jp2,kp0) + g1*coef
+
+ coef=a1*b2*c1
+ ug(ip1,jp2,kp1) = ug(ip1,jp2,kp1) + g1*coef
+
+ coef=a1*b2*c2
+ ug(ip1,jp2,kp2) = ug(ip1,jp2,kp2) + g1*coef
+
+ coef=a1*b2*c3
+ ug(ip1,jp2,kp3) = ug(ip1,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b3*c0
+ ug(ip1,jp3,kp0) = ug(ip1,jp3,kp0) + g1*coef
+
+ coef=a1*b3*c1
+ ug(ip1,jp3,kp1) = ug(ip1,jp3,kp1) + g1*coef
+
+ coef=a1*b3*c2
+ ug(ip1,jp3,kp2) = ug(ip1,jp3,kp2) + g1*coef
+
+ coef=a1*b3*c3
+ ug(ip1,jp3,kp3) = ug(ip1,jp3,kp3) + g1*coef
+
+ccc
+ coef=a2*b0*c0
+ ug(ip2,jp0,kp0) = ug(ip2,jp0,kp0) + g1*coef
+
+ coef=a2*b0*c1
+ ug(ip2,jp0,kp1) = ug(ip2,jp0,kp1) + g1*coef
+
+ coef=a2*b0*c2
+ ug(ip2,jp0,kp2) = ug(ip2,jp0,kp2) + g1*coef
+
+ coef=a2*b0*c3
+ ug(ip2,jp0,kp3) = ug(ip2,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b1*c0
+ ug(ip2,jp1,kp0) = ug(ip2,jp1,kp0) + g1*coef
+
+ coef=a2*b1*c1
+ ug(ip2,jp1,kp1) = ug(ip2,jp1,kp1) + g1*coef
+
+ coef=a2*b1*c2
+ ug(ip2,jp1,kp2) = ug(ip2,jp1,kp2) + g1*coef
+
+ coef=a2*b1*c3
+ ug(ip2,jp1,kp3) = ug(ip2,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b2*c0
+ ug(ip2,jp2,kp0) = ug(ip2,jp2,kp0) + g1*coef
+
+ coef=a2*b2*c1
+ ug(ip2,jp2,kp1) = ug(ip2,jp2,kp1) + g1*coef
+
+ coef=a2*b2*c2
+ ug(ip2,jp2,kp2) = ug(ip2,jp2,kp2) + g1*coef
+
+ coef=a2*b2*c3
+ ug(ip2,jp2,kp3) = ug(ip2,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b3*c0
+ ug(ip2,jp3,kp0) = ug(ip2,jp3,kp0) + g1*coef
+
+ coef=a2*b3*c1
+ ug(ip2,jp3,kp1) = ug(ip2,jp3,kp1) + g1*coef
+
+ coef=a2*b3*c2
+ ug(ip2,jp3,kp2) = ug(ip2,jp3,kp2) + g1*coef
+
+ coef=a2*b3*c3
+ ug(ip2,jp3,kp3) = ug(ip2,jp3,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b0*c0
+ ug(ip3,jp0,kp0) = ug(ip3,jp0,kp0) + g1*coef
+
+ coef=a3*b0*c1
+ ug(ip3,jp0,kp1) = ug(ip3,jp0,kp1) + g1*coef
+
+ coef=a3*b0*c2
+ ug(ip3,jp0,kp2) = ug(ip3,jp0,kp2) + g1*coef
+
+ coef=a3*b0*c3
+ ug(ip3,jp0,kp3) = ug(ip3,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b1*c0
+ ug(ip3,jp1,kp0) = ug(ip3,jp1,kp0) + g1*coef
+
+ coef=a3*b1*c1
+ ug(ip3,jp1,kp1) = ug(ip3,jp1,kp1) + g1*coef
+
+ coef=a3*b1*c2
+ ug(ip3,jp1,kp2) = ug(ip3,jp1,kp2) + g1*coef
+
+ coef=a3*b1*c3
+ ug(ip3,jp1,kp3) = ug(ip3,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b2*c0
+ ug(ip3,jp2,kp0) = ug(ip3,jp2,kp0) + g1*coef
+
+ coef=a3*b2*c1
+ ug(ip3,jp2,kp1) = ug(ip3,jp2,kp1) + g1*coef
+
+ coef=a3*b2*c2
+ ug(ip3,jp2,kp2) = ug(ip3,jp2,kp2) + g1*coef
+
+ coef=a3*b2*c3
+ ug(ip3,jp2,kp3) = ug(ip3,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b3*c0
+ ug(ip3,jp3,kp0) = ug(ip3,jp3,kp0) + g1*coef
+
+ coef=a3*b3*c1
+ ug(ip3,jp3,kp1) = ug(ip3,jp3,kp1) + g1*coef
+
+ coef=a3*b3*c2
+ ug(ip3,jp3,kp2) = ug(ip3,jp3,kp2) + g1*coef
+
+ coef=a3*b3*c3
+ ug(ip3,jp3,kp3) = ug(ip3,jp3,kp3) + g1*coef
+
+ccc
+
+20 CONTINUE
+
+! goto 1111
+
+ npart=0
+
+ do k=1,nz2
+ z=z0+(k-1)*dz2
+ do j=1,ny2
+ y=y0+(j-1)*dy2
+ do i=1,nx2
+ x=x0+(i-1)*dx2
+ strength=abs(ug(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ xp2(npart)=x
+ yp2(npart)=y
+ zp2(npart)=z
+ phip(npart)=ug(i,j,k)*vol
+ endif
+ enddo
+ enddo
+ enddo
+
+1111 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..83773b37e52d0f9b64ce3d9b191bd572ac22dab3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remesh_tag.f
@@ -0,0 +1,86 @@
+ subroutine remesh_tag(ntag,itag,itype,icfl)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension itag(*),itype(*),icfl(*)
+
+
+ dxinv=1./dx
+ x0=-1.
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=mod(i,nx)+1
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+ ip4=mod(ip4+nx,nx) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(ip0)=ug(ip0)+a0*u1
+ ug(ip1)=ug(ip1)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(ip2)=ug(ip2)+xx1*u1-yy1*u2
+ ug(ip3)=ug(ip3)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(ip4)=ug(ip4)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dx-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(ip0)=ug(ip0)+a0*u1
+ ug(ip1)=ug(ip1)+(1.-a0)*u1+(1.-b2)*u2
+ ug(ip2)=ug(ip2)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..f0ab054f10c948c6bae92a87460691d0d4511ca5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2.f
@@ -0,0 +1,95 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ endif
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..0cf7c7f68d94d92732a33e2a2d4c00ad0cdc68d2
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_limit.f
@@ -0,0 +1,71 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk,sl1,sl2)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*),sl1(*),sl2(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ if (itype(n).eq.1) ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c Lambda2:
+c
+c avec les pentes:
+
+ a0=0.5*((xx1-0.5)**2)-sl2(n)/8.
+ a1=0.75-xx1**2+(sl1(n)+sl2(n))/8.
+ a2=0.5*((xx1+0.5)**2)-sl1(n)/8.
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..ac61cf49c172c11a2123450998ec5f9b4eba81a4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l2_tag.f
@@ -0,0 +1,76 @@
+ subroutine remeshx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag-1,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+xx1*u1-yy1*u2
+ ug(ip3,jj,kk)=ug(ip3,jj,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(ip4,jj,kk)=ug(ip4,jj,kk)+b2*u2
+
+ else
+! case (c') and (d')
+c
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+b2*u2
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..8104d3f894e16ed60e875d2ce7cde2890e6b64c1
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4.f
@@ -0,0 +1,83 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+ ug(ip3,jj,kk) = ug(ip3,jj,kk) + g1*a3
+ ug(ip4,jj,kk) = ug(ip4,jj,kk) + g1*a4
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..be95aa82c57ed58a3cd8deb7308cd3108f68ac27
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ ug(ip3m,jj,kk)=ug(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(ip2m,jj,kk)=ug(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ ug(ip1m,jj,kk)=ug(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip1p,jj,kk)=ug(ip1p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(ip2p,jj,kk)=ug(ip2p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(ip3p,jj,kk)=ug(ip3p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(ip4p,jj,kk)=ug(ip4p,jj,kk)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip5p,jj,kk)=ug(ip5p,jj,kk)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ ug(ip3m,jj,kk)=ug(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(ip2m,jj,kk)=ug(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ ug(ip1m,jj,kk)=ug(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(ip1p,jj,kk)=ug(ip1p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(ip2p,jj,kk)=ug(ip2p,jj,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(ip3p,jj,kk)=ug(ip3p,jj,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_m4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_m4.f
new file mode 100644
index 0000000000000000000000000000000000000000..7c8d24d8fb4f71afb31986a32d54fd4100174733
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_m4.f
@@ -0,0 +1,75 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+ ug(ip3,jj,kk) = ug(ip3,jj,kk) + g1*a3
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..67c9cd8d3bc023557cb8be011f65eaae789623c7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshx_omx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg1(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg1(ip0,jj,kk) = omg1(ip0,jj,kk) + g1*a0
+ omg1(ip1,jj,kk) = omg1(ip1,jj,kk) + g1*a1
+ omg1(ip2,jj,kk) = omg1(ip2,jj,kk) + g1*a2
+ omg1(ip3,jj,kk) = omg1(ip3,jj,kk) + g1*a3
+ omg1(ip4,jj,kk) = omg1(ip4,jj,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..a3e3b3e4415e40cc5029eaaa91e8efe2f44a8820
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omx_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshx_omx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg1(ip3m,jj,kk)=omg1(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(ip2m,jj,kk)=omg1(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg1(ip1m,jj,kk)=omg1(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(ip0,jj,kk)=omg1(ip0,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(ip1p,jj,kk)=omg1(ip1p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(ip2p,jj,kk)=omg1(ip2p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(ip3p,jj,kk)=omg1(ip3p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(ip4p,jj,kk)=omg1(ip4p,jj,kk)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(ip5p,jj,kk)=omg1(ip5p,jj,kk)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg1(ip3m,jj,kk)=omg1(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(ip2m,jj,kk)=omg1(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg1(ip1m,jj,kk)=omg1(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(ip0,jj,kk)=omg1(ip0,jj,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(ip1p,jj,kk)=omg1(ip1p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(ip2p,jj,kk)=omg1(ip2p,jj,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(ip3p,jj,kk)=omg1(ip3p,jj,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..ec4c3100f1cbe5ed1e1c56399b61aec412d8ea1f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshx_omy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg2(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg2(ip0,jj,kk) = omg2(ip0,jj,kk) + g1*a0
+ omg2(ip1,jj,kk) = omg2(ip1,jj,kk) + g1*a1
+ omg2(ip2,jj,kk) = omg2(ip2,jj,kk) + g1*a2
+ omg2(ip3,jj,kk) = omg2(ip3,jj,kk) + g1*a3
+ omg2(ip4,jj,kk) = omg2(ip4,jj,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..c60b9e073b8fd213f1332d8e92dcac5f31e874b4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omy_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshx_omy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+c reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+c print*,xx1m,xx0,xx1p,xx2p
+c reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg2(ip3m,jj,kk)=omg2(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(ip2m,jj,kk)=omg2(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg2(ip1m,jj,kk)=omg2(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(ip0,jj,kk)=omg2(ip0,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(ip1p,jj,kk)=omg2(ip1p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(ip2p,jj,kk)=omg2(ip2p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(ip3p,jj,kk)=omg2(ip3p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(ip4p,jj,kk)=omg2(ip4p,jj,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(ip5p,jj,kk)=omg2(ip5p,jj,kk)+u2p*coef2p
+c
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+c case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg2(ip3m,jj,kk)=omg2(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(ip2m,jj,kk)=omg2(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg2(ip1m,jj,kk)=omg2(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(ip0,jj,kk)=omg2(ip0,jj,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(ip1p,jj,kk)=omg2(ip1p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(ip2p,jj,kk)=omg2(ip2p,jj,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(ip3p,jj,kk)=omg2(ip3p,jj,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..7f79cf52356eabf56a17944697bf195711567a3d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshx_omz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg3(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg3(ip0,jj,kk) = omg3(ip0,jj,kk) + g1*a0
+ omg3(ip1,jj,kk) = omg3(ip1,jj,kk) + g1*a1
+ omg3(ip2,jj,kk) = omg3(ip2,jj,kk) + g1*a2
+ omg3(ip3,jj,kk) = omg3(ip3,jj,kk) + g1*a3
+ omg3(ip4,jj,kk) = omg3(ip4,jj,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..2d25ebd4ae3380c7f9fdc81489dc15e0bcc3dbd6
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_omz_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshx_omz_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg3(ip3m,jj,kk)=omg3(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(ip2m,jj,kk)=omg3(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg3(ip1m,jj,kk)=omg3(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(ip0,jj,kk)=omg3(ip0,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(ip1p,jj,kk)=omg3(ip1p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(ip2p,jj,kk)=omg3(ip2p,jj,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(ip3p,jj,kk)=omg3(ip3p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(ip4p,jj,kk)=omg3(ip4p,jj,kk)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(ip5p,jj,kk)=omg3(ip5p,jj,kk)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg3(ip3m,jj,kk)=omg3(ip3m,jj,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(ip2m,jj,kk)=omg3(ip2m,jj,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg3(ip1m,jj,kk)=omg3(ip1m,jj,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(ip0,jj,kk)=omg3(ip0,jj,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(ip1p,jj,kk)=omg3(ip1p,jj,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(ip2p,jj,kk)=omg3(ip2p,jj,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(ip3p,jj,kk)=omg3(ip3p,jj,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_tag_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_tag_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..2e5badafd0ac174fb94bf7400b339b4b173086e1
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshx_tag_limit.f
@@ -0,0 +1,82 @@
+ subroutine remeshx_tag(ntag,itag,itype,icfl,jj,kk,sl)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+ dimension sl(*)
+
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag-1,2
+ i=itag(n)
+ ib=mod(i-2+nx,nx)+1
+ ii=itag(n+1)
+ iib=mod(ii-2+nx,nx)+1
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ a1=0.75-xx1**2+(sl(i)+sl(ib))/8.
+ b1=0.75-yy1**2+(sl(ii)+sl(iib))/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+xx1*u1-yy1*u2
+ ug(ip3,jj,kk)=ug(ip3,jj,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(ip4,jj,kk)=ug(ip4,jj,kk)+b2*u2
+
+ else
+! case (c') and (d')
+c
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+b2*u2
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..278ab014d7d19161be32e4acafeffbe31599e804
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2.f
@@ -0,0 +1,83 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..67dcbb9344c77de72ade72f9c922e4a9aaf55f8e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_limit.f
@@ -0,0 +1,56 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk,sl1,sl2)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*),sl1(*),sl2(*)
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ if (itype(n).eq.1) ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c Lambda2:
+c
+c avec les pentes:
+
+ a0=0.5*((xx1-0.5)**2)-sl2(n)/8.
+ a1=0.75-xx1**2+(sl1(n)+sl2(n))/8.
+ a2=0.5*((xx1+0.5)**2)-sl1(n)/8.
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..48ac7b5179b500118a62a08a47fd046a3f0d5cd7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l2_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+xx1*u1-yy1*u2
+ ug(jj,ip3,kk)=ug(jj,ip3,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(jj,ip4,kk)=ug(jj,ip4,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..6790ace02906420343fdb9c7ca1cb224d58444cc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4.f
@@ -0,0 +1,83 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+ ug(jj,ip3,kk) = ug(jj,ip3,kk) + g1*a3
+ ug(jj,ip4,kk) = ug(jj,ip4,kk) + g1*a4
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..bf25330479bc272be188ea9b2c26a23a036c67f5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_l4_tag.f
@@ -0,0 +1,178 @@
+ subroutine remeshy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! do n=1,1
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ ug(jj,ip3m,kk)=ug(jj,ip3m,kk)+u1m*coef1m
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(jj,ip2m,kk)=ug(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ ug(jj,ip1m,kk)=ug(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,ip1p,kk)=ug(jj,ip1p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(jj,ip2p,kk)=ug(jj,ip2p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(jj,ip3p,kk)=ug(jj,ip3p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(jj,ip4p,kk)=ug(jj,ip4p,kk)+u1p*coef1p+u2p*coef2p
+
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,ip5p,kk)=ug(jj,ip5p,kk)+u2p*coef2p
+
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ ug(jj,ip3m,kk)=ug(jj,ip3m,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(jj,ip2m,kk)=ug(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ ug(jj,ip1m,kk)=ug(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(jj,ip1p,kk)=ug(jj,ip1p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(jj,ip2p,kk)=ug(jj,ip2p,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,ip3p,kk)=ug(jj,ip3p,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_m4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_m4.f
new file mode 100644
index 0000000000000000000000000000000000000000..1242e5467c31318c8ad38bb9533ffa4d5dd62321
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_m4.f
@@ -0,0 +1,61 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+ ug(jj,ip3,kk) = ug(jj,ip3,kk) + g1*a3
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..d5669b3057a564eb66637169cf035efebf24dba1
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshy_omx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg1(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg1(jj,ip0,kk) = omg1(jj,ip0,kk) + g1*a0
+ omg1(jj,ip1,kk) = omg1(jj,ip1,kk) + g1*a1
+ omg1(jj,ip2,kk) = omg1(jj,ip2,kk) + g1*a2
+ omg1(jj,ip3,kk) = omg1(jj,ip3,kk) + g1*a3
+ omg1(jj,ip4,kk) = omg1(jj,ip4,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..0bbfb884db756e87a93e6bc7d03fdc364d2c561c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omx_l4_tag.f
@@ -0,0 +1,178 @@
+ subroutine remeshy_omx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! do n=1,1
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg1(jj,ip3m,kk)=omg1(jj,ip3m,kk)+u1m*coef1m
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(jj,ip2m,kk)=omg1(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg1(jj,ip1m,kk)=omg1(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,ip0,kk)=omg1(jj,ip0,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,ip1p,kk)=omg1(jj,ip1p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(jj,ip2p,kk)=omg1(jj,ip2p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(jj,ip3p,kk)=omg1(jj,ip3p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(jj,ip4p,kk)=omg1(jj,ip4p,kk)+u1p*coef1p+u2p*coef2p
+
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,ip5p,kk)=omg1(jj,ip5p,kk)+u2p*coef2p
+
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg1(jj,ip3m,kk)=omg1(jj,ip3m,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(jj,ip2m,kk)=omg1(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg1(jj,ip1m,kk)=omg1(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(jj,ip0,kk)=omg1(jj,ip0,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(jj,ip1p,kk)=omg1(jj,ip1p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(jj,ip2p,kk)=omg1(jj,ip2p,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,ip3p,kk)=omg1(jj,ip3p,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..02cb35d2bcd7a5b97769a95adf274e1f0f72c6d3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshy_omy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg2(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+! Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg2(jj,ip0,kk) = omg2(jj,ip0,kk) + g1*a0
+ omg2(jj,ip1,kk) = omg2(jj,ip1,kk) + g1*a1
+ omg2(jj,ip2,kk) = omg2(jj,ip2,kk) + g1*a2
+ omg2(jj,ip3,kk) = omg2(jj,ip3,kk) + g1*a3
+ omg2(jj,ip4,kk) = omg2(jj,ip4,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..37e6665791884ea81e33882e83b8077a4a1fb885
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omy_l4_tag.f
@@ -0,0 +1,178 @@
+ subroutine remeshy_omy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! do n=1,1
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg2(jj,ip3m,kk)=omg2(jj,ip3m,kk)+u1m*coef1m
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(jj,ip2m,kk)=omg2(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg2(jj,ip1m,kk)=omg2(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,ip0,kk)=omg2(jj,ip0,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,ip1p,kk)=omg2(jj,ip1p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(jj,ip2p,kk)=omg2(jj,ip2p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(jj,ip3p,kk)=omg2(jj,ip3p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(jj,ip4p,kk)=omg2(jj,ip4p,kk)+u1p*coef1p+u2p*coef2p
+
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,ip5p,kk)=omg2(jj,ip5p,kk)+u2p*coef2p
+
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg2(jj,ip3m,kk)=omg2(jj,ip3m,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(jj,ip2m,kk)=omg2(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg2(jj,ip1m,kk)=omg2(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(jj,ip0,kk)=omg2(jj,ip0,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(jj,ip1p,kk)=omg2(jj,ip1p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(jj,ip2p,kk)=omg2(jj,ip2p,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,ip3p,kk)=omg2(jj,ip3p,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..d21f51d661febb7020b73f769fa680be34f3ae1f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshy_omz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg3(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg3(jj,ip0,kk) = omg3(jj,ip0,kk) + g1*a0
+ omg3(jj,ip1,kk) = omg3(jj,ip1,kk) + g1*a1
+ omg3(jj,ip2,kk) = omg3(jj,ip2,kk) + g1*a2
+ omg3(jj,ip3,kk) = omg3(jj,ip3,kk) + g1*a3
+ omg3(jj,ip4,kk) = omg3(jj,ip4,kk) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..0bbd81e3af769edd4b55088272ce0279b2d9ec3d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_omz_l4_tag.f
@@ -0,0 +1,178 @@
+ subroutine remeshy_omz_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+c do n=1,1
+c reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+c reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg3(jj,ip3m,kk)=omg3(jj,ip3m,kk)+u1m*coef1m
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(jj,ip2m,kk)=omg3(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg3(jj,ip1m,kk)=omg3(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,ip0,kk)=omg3(jj,ip0,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,ip1p,kk)=omg3(jj,ip1p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(jj,ip2p,kk)=omg3(jj,ip2p,kk)
+ 1 +u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(jj,ip3p,kk)=omg3(jj,ip3p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(jj,ip4p,kk)=omg3(jj,ip4p,kk)+u1p*coef1p+u2p*coef2p
+
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,ip5p,kk)=omg3(jj,ip5p,kk)+u2p*coef2p
+
+c
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+c case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg3(jj,ip3m,kk)=omg3(jj,ip3m,kk)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(jj,ip2m,kk)=omg3(jj,ip2m,kk)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg3(jj,ip1m,kk)=omg3(jj,ip1m,kk)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(jj,ip0,kk)=omg3(jj,ip0,kk)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(jj,ip1p,kk)=omg3(jj,ip1p,kk)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(jj,ip2p,kk)=omg3(jj,ip2p,kk)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,ip3p,kk)=omg3(jj,ip3p,kk)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_tag_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_tag_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..c99271410cc323ceadf069e5bab1b7bf284a7218
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshy_tag_limit.f
@@ -0,0 +1,92 @@
+ subroutine remeshy_tag(ntag,itag,itype,icfl,jj,kk,sl)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+ dimension sl(*)
+
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ib=mod(i-2+nx,nx)+1
+ ii=itag(n+1)
+ iib=mod(ii-2+nx,nx)+1
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ a1=0.75-xx1**2+(sl(i)+sl(ib))/8.
+ b1=0.75-yy1**2+(sl(ii)+sl(iib))/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+xx1*u1-yy1*u2
+ ug(jj,ip3,kk)=ug(jj,ip3,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(jj,ip4,kk)=ug(jj,ip4,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..835bfca444cce0d6a4a4dd23abbf7a10d32cfee9
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2.f
@@ -0,0 +1,83 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..6306e6bcfbb559f7cbaf9ce3e370c502c4b4c05b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_limit.f
@@ -0,0 +1,55 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk,sl1,sl2)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*),sl1(*),sl2(*)
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ if (itype(n).eq.1) ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c Lambda2:
+c
+c avec les pentes:
+
+ a0=0.5*((xx1-0.5)**2)-sl2(n)/8.
+ a1=0.75-xx1**2+(sl1(n)+sl2(n))/8.
+ a2=0.5*((xx1+0.5)**2)-sl1(n)/8.
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..af3a92781f2dbd229ab78d92dea3e214ed6bdb5f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l2_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshz_tag(ntag,itag,itype,icfl,kk,jj)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+xx1*u1-yy1*u2
+ ug(kk,jj,ip3)=ug(kk,jj,ip3)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(kk,jj,ip4)=ug(kk,jj,ip4)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+(1.-a0)*u1+(1.-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..43dfb7d957fc77c51604d6af23c07c6cd487bf5d
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4.f
@@ -0,0 +1,83 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+ ug(jj,kk,ip3) = ug(jj,kk,ip3) + g1*a3
+ ug(jj,kk,ip4) = ug(jj,kk,ip4) + g1*a4
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..b93bfe3c93d34c8e65ee5d2bd93712d9c36aba55
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshz_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+c reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+c print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+c print*,xx1m,xx0,xx1p,xx2p
+c reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ ug(jj,kk,ip3m)=ug(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(jj,kk,ip2m)=ug(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ ug(jj,kk,ip1m)=ug(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,kk,ip0)=ug(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,kk,ip1p)=ug(jj,kk,ip1p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(jj,kk,ip2p)=ug(jj,kk,ip2p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(jj,kk,ip3p)=ug(jj,kk,ip3p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(jj,kk,ip4p)=ug(jj,kk,ip4p)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,kk,ip5p)=ug(jj,kk,ip5p)+u2p*coef2p
+c
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+c case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ ug(jj,kk,ip3m)=ug(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ ug(jj,kk,ip2m)=ug(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ ug(jj,kk,ip1m)=ug(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ ug(jj,kk,ip0)=ug(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ ug(jj,kk,ip1p)=ug(jj,kk,ip1p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ ug(jj,kk,ip2p)=ug(jj,kk,ip2p)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ ug(jj,kk,ip3p)=ug(jj,kk,ip3p)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_m4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_m4.f
new file mode 100644
index 0000000000000000000000000000000000000000..96b9ec719964a0844473fa919187f07db7197161
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_m4.f
@@ -0,0 +1,62 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+ ug(jj,kk,ip3) = ug(jj,kk,ip3) + g1*a3
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..2434190c4884319047053ac6353003752b007928
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshz_omx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg1(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg1(jj,kk,ip0) = omg1(jj,kk,ip0) + g1*a0
+ omg1(jj,kk,ip1) = omg1(jj,kk,ip1) + g1*a1
+ omg1(jj,kk,ip2) = omg1(jj,kk,ip2) + g1*a2
+ omg1(jj,kk,ip3) = omg1(jj,kk,ip3) + g1*a3
+ omg1(jj,kk,ip4) = omg1(jj,kk,ip4) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..a20f4b72215a7ce16e78c5111585e18410fe6fa1
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omx_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshz_omx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg1(jj,kk,ip3m)=omg1(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(jj,kk,ip2m)=omg1(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg1(jj,kk,ip1m)=omg1(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,kk,ip0)=omg1(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,kk,ip1p)=omg1(jj,kk,ip1p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(jj,kk,ip2p)=omg1(jj,kk,ip2p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(jj,kk,ip3p)=omg1(jj,kk,ip3p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(jj,kk,ip4p)=omg1(jj,kk,ip4p)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,kk,ip5p)=omg1(jj,kk,ip5p)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg1(jj,kk,ip3m)=omg1(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg1(jj,kk,ip2m)=omg1(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg1(jj,kk,ip1m)=omg1(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg1(jj,kk,ip0)=omg1(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg1(jj,kk,ip1p)=omg1(jj,kk,ip1p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg1(jj,kk,ip2p)=omg1(jj,kk,ip2p)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg1(jj,kk,ip3p)=omg1(jj,kk,ip3p)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..f82df1cb40f8b8e216ff89ccc4f6c05697c4ae38
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshz_omy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg2(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg2(jj,kk,ip0) = omg2(jj,kk,ip0) + g1*a0
+ omg2(jj,kk,ip1) = omg2(jj,kk,ip1) + g1*a1
+ omg2(jj,kk,ip2) = omg2(jj,kk,ip2) + g1*a2
+ omg2(jj,kk,ip3) = omg2(jj,kk,ip3) + g1*a3
+ omg2(jj,kk,ip4) = omg2(jj,kk,ip4) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..3044f7fe8d5cc584515a0a1cd2d5289ed28ff0da
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omy_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshz_omy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg2(jj,kk,ip3m)=omg2(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(jj,kk,ip2m)=omg2(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg2(jj,kk,ip1m)=omg2(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,kk,ip0)=omg2(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,kk,ip1p)=omg2(jj,kk,ip1p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(jj,kk,ip2p)=omg2(jj,kk,ip2p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(jj,kk,ip3p)=omg2(jj,kk,ip3p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(jj,kk,ip4p)=omg2(jj,kk,ip4p)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,kk,ip5p)=omg2(jj,kk,ip5p)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg2(jj,kk,ip3m)=omg2(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg2(jj,kk,ip2m)=omg2(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg2(jj,kk,ip1m)=omg2(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg2(jj,kk,ip0)=omg2(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg2(jj,kk,ip1p)=omg2(jj,kk,ip1p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg2(jj,kk,ip2p)=omg2(jj,kk,ip2p)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg2(jj,kk,ip3p)=omg2(jj,kk,ip3p)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..342b5b7a14ca1664c06ce80c37905f5133c67825
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4.f
@@ -0,0 +1,70 @@
+ subroutine remeshz_omz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ omg3(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ else
+ ip1 = nint((x-x0)*dxinv)
+ endif
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+
+
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=xx1-1.
+ xx3=xx1+2.
+ xx4=xx1-2.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c
+c Lambda4:
+c
+ a0 = -xx4*xx2*xx1*xx3/6.
+ a1 = xx0*xx2*xx3*xx4/4.
+ a2 = -xx0*xx1*xx3*xx4/6.
+ a3 = xx0*xx1*xx2*xx4/24.
+ a4 = xx0*xx1*xx2*xx3/24.
+
+ omg3(jj,kk,ip0) = omg3(jj,kk,ip0) + g1*a0
+ omg3(jj,kk,ip1) = omg3(jj,kk,ip1) + g1*a1
+ omg3(jj,kk,ip2) = omg3(jj,kk,ip2) + g1*a2
+ omg3(jj,kk,ip3) = omg3(jj,kk,ip3) + g1*a3
+ omg3(jj,kk,ip4) = omg3(jj,kk,ip4) + g1*a4
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4_tag.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..8e907cf9c66eeedd589cc5eee9e85e1c9fe49077
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_omz_l4_tag.f
@@ -0,0 +1,171 @@
+ subroutine remeshz_omz_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+
+ do n=1,ntag-1,4
+! reperage des 4 particules taggees: positions, poids
+ i=itag(n)
+ ii=itag(n+1)
+ iii=itag(n+2)
+ iiii=itag(n+3)
+ x1m=xp(i)
+ x0=xp(ii)
+ x1p=xp(iii)
+ x2p=xp(iiii)
+ u1m=up(i)
+ u0=up(ii)
+ u1p=up(iii)
+ u2p=up(iiii)
+! print*,n,i,x1m,x0,x1p,x2p,u1m,u0,u1p,u2p,itype(i),itype(ii),
+c 1 itype(iii),itype(iiii)
+c
+c reperage du point de base pour les 4 particules taggees selon le type
+ if (itype(i).eq.0) then
+ ip0 = int((x0-xmin)*dxinv)
+ ip1m = int((x1m-xmin)*dxinv)
+ ip1p = nint((x1p-xmin)*dxinv)
+ ip2p = nint((x2p-xmin)*dxinv)
+ else
+ ip0 = nint((x0-xmin)*dxinv)
+ ip1m = nint((x1m-xmin)*dxinv)
+ ip1p = int((x1p-xmin)*dxinv)
+ ip2p = int((x2p-xmin)*dxinv)
+ endif
+ xx0 = (x0 - float(ip0)*dx2-xmin)*dxinv
+ xx1m = (x1m - float(ip1m)*dx2-xmin)*dxinv
+ xx1p = (x1p - float(ip1p)*dx2-xmin)*dxinv
+ xx2p = (x2p - float(ip2p)*dx2-xmin)*dxinv
+! print*,xx1m,xx0,xx1p,xx2p
+! reperage des points de grille concernes
+c de I-3 a I+5 ou I est point de grille a gauche de particule x0
+ ip3m=ip0-3
+ ip2m=ip0-2
+ ip1m=ip0-1
+ ip5p=ip0+5
+ ip4p=ip0+4
+ ip3p=ip0+3
+ ip2p=ip0+2
+ ip1p=ip0+1
+ ip0=mod(ip0+nx,nx) +1
+ ip1p=mod(ip1p+nx,nx) +1
+ ip2p=mod(ip2p+nx,nx) +1
+ ip3p=mod(ip3p+nx,nx) +1
+ ip4p=mod(ip4p+nx,nx) +1
+ ip5p=mod(ip5p+nx,nx) +1
+ ip1m=mod(ip1m+nx,nx) +1
+ ip2m=mod(ip2m+nx,nx) +1
+ ip3m=mod(ip3m+nx,nx) +1
+c cases (c) and (d)
+c
+ if (itype(i).eq.0) then
+ coef1m=(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+1)/24.
+ omg3(jj,kk,ip3m)=omg3(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*xx1m*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(jj,kk,ip2m)=omg3(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*xx0*(xx0+2)/6.
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ omg3(jj,kk,ip1m)=omg3(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef1p=-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,kk,ip0)=omg3(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef1m=coef1m-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+3)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,kk,ip1p)=omg3(jj,kk,ip1p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ coef0=-(xx0-3.)*(xx0-1.)*(xx0+0.)*(xx0+1)/6.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(jj,kk,ip2p)=omg3(jj,kk,ip2p)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+1)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(jj,kk,ip3p)=omg3(jj,kk,ip3p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(jj,kk,ip4p)=omg3(jj,kk,ip4p)+u1p*coef1p+u2p*coef2p
+!
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,kk,ip5p)=omg3(jj,kk,ip5p)+u2p*coef2p
+c
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c
+! case (c') and (d')
+ else
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+1)/24.
+ omg3(jj,kk,ip3m)=omg3(jj,kk,ip3m)+u1m*coef1m
+c
+ coef1m=-(xx1m-2.)*(xx1m-1.)*(xx1m+0.)*(xx1m+2)/6.
+ coef0=(xx0-2.)*(xx0-1.)*xx0*(xx0+1)/24.
+ omg3(jj,kk,ip2m)=omg3(jj,kk,ip2m)+u1m*coef1m+u0*coef0
+c
+ coef1m=(xx1m-2.)*(xx1m-1.)*(xx1m+1.)*(xx1m+2)/4.
+ coef0=-(xx0-2.)*(xx0-1.)*(xx0+0.)*(xx0+2)/6.
+ coef1p=(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ omg3(jj,kk,ip1m)=omg3(jj,kk,ip1m)+u1m*coef1m+u0*coef0+u1p*coef1p
+c
+ coef1m=-(xx1m-2.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/6.
+ coef1m=coef1m+(xx1m-1.)*(xx1m-0.)*(xx1m+1.)*(xx1m+2)/24.
+ coef0=(xx0-2.)*(xx0-1.)*(xx0+1.)*(xx0+2)/4.
+ coef0=coef0-(xx0-2.)*(xx0-0.)*(xx0+1.)*(xx0+2)/6.
+ coef0=coef0+(xx0-1.)*(xx0-0.)*(xx0+1.)*(xx0+2)/24.
+ coef0=coef0-(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+1)/24.
+ coef1p=coef1p-(xx1p-3.)*(xx1p-2.)*(xx1p-1.)*(xx1p+0)/24.
+ coef1p=coef1p-(xx1p-2.)*(xx1p-1.)*(xx1p+0.)*(xx1p+2)/6.
+ coef1p=coef1p+(xx1p-2.)*(xx1p-1.)*(xx1p+1.)*(xx1p+2)/4.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+1)/24.
+ coef2p=coef2p-(xx2p-2.)*(xx2p-1.)*(xx2p+0.)*(xx2p+2)/6.
+ omg3(jj,kk,ip0)=omg3(jj,kk,ip0)+
+ 1 u1m*coef1m+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef0=(xx0-0.)*(xx0+1.)*(xx0+2.)*(xx0+3)/24.
+ coef1p=-(xx1p-2.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/6.
+ coef2p=(xx2p-2.)*(xx2p-1.)*(xx2p+1.)*(xx2p+2)/4.
+ omg3(jj,kk,ip1p)=omg3(jj,kk,ip1p)+u0*coef0+u1p*coef1p+u2p*coef2p
+c
+ coef1p=(xx1p-1.)*(xx1p-0.)*(xx1p+1.)*(xx1p+2)/24.
+ coef2p=-(xx2p-2.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/6.
+ omg3(jj,kk,ip2p)=omg3(jj,kk,ip2p)+u1p*coef1p+u2p*coef2p
+c
+ coef2p=(xx2p-1.)*(xx2p-0.)*(xx2p+1.)*(xx2p+2)/24.
+ omg3(jj,kk,ip3p)=omg3(jj,kk,ip3p)+u2p*coef2p
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_tag_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_tag_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..c5035052748c60a5e5b45779487a7e9b3d5b7ddf
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/remeshz_tag_limit.f
@@ -0,0 +1,91 @@
+ subroutine remeshz_tag(ntag,itag,itype,icfl,kk,jj,sl)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+ dimension sl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ib=mod(i-2+nx,nx)+1
+ ii=itag(n+1)
+ iib=mod(ii-2+nx,nx)+1
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ a1=0.75-xx1**2+(sl(i)+sl(ib))/8.
+ b1=0.75-yy1**2+(sl(ii)+sl(iib))/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+xx1*u1-yy1*u2
+ ug(kk,jj,ip3)=ug(kk,jj,ip3)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(kk,jj,ip4)=ug(kk,jj,ip4)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c version avec limituers de pente
+ a0=0.5*((xx1-0.5)**2)-sl(ib)/8.
+ b2=0.5*((yy1+0.5)**2)-sl(ii)/8.
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+(1.-a0)*u1+(1.-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/slopes.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/slopes.f
new file mode 100644
index 0000000000000000000000000000000000000000..7a38f2d9615b002b7f779fd2ceb91bc53f9888aa
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/slopes.f
@@ -0,0 +1,54 @@
+ subroutine slopes(dt,np,sl)
+
+ include 'param.i'
+ include 'param.h'
+! include 'arrays.h'
+
+ common/remesh/xp0(npg),xp(npg),up(npg),vx(npg)
+
+ dimension sl(*)
+
+c al1: pente pour v>0
+c al2: pente pour v<0
+
+ do n=1,np
+ sl(n)=0.
+ enddo
+! goto 111
+ do n=1,np
+ afl=vx(n)*dt/dx-nint(vx(n)*dt/dx)
+ phimax1=4.*amin1(0.9,(afl+0.5)**2)
+ phimax2=4.*amin1(0.9,(afl-0.5)**2)
+ nt=mod(n+nx,nx)+1
+ ntt=mod(n+1+nx,nx)+1
+ nb=mod(n-2+nx,nx)+1
+ apu=up(nt)-up(n)
+ apuu=up(ntt)-up(nt)
+ apb=up(n)-up(nb)
+ al1=0.
+ al2=0.
+c limiteur de pente
+ if (abs(apu).ge.0.00001) then
+ rr1=apb/apu
+ rr2=apuu/apu
+c sweeby :
+ al1=amax1(0.,amin1(phimax1*rr1,phimax1))
+ al1=amax1(al1,amin1(phimax1,rr1))
+ al2=amax1(0.,amin1(phimax2*rr2,phimax2))
+ al2=amax1(al2,amin1(phimax2,rr2))
+c van leer :
+ if (rr1.gt.0.) al1=phimax1*rr1/(1.+rr1)
+ if (rr2.gt.0.) al2=phimax2*rr2/(1.+rr2)
+ endif
+ sl(n)=al1
+ if (afl.le.0.) sl(n)=al2
+c pour retrouver lambda 2 : sl=1
+ sl(n)=0.
+ enddo
+111 continue
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/spec.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec.f
new file mode 100644
index 0000000000000000000000000000000000000000..729241a58965ce115d36f64da545478680beaccc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec.f
@@ -0,0 +1,106 @@
+ program spectre
+ parameter(n=32,ns2=n/2,n1=1-ns2)
+c
+ complex u,v,w,um,vm,wm
+ dimension u(0:ns2,n1:ns2,n1:ns2),
+ 2 v(0:ns2,n1:ns2,n1:ns2),
+ 4 w(0:ns2,n1:ns2,n1:ns2),
+ 5 um(n1:ns2,n1:ns2,n1:ns2),
+ 6 vm(n1:ns2,n1:ns2,n1:ns2),
+ 7 wm(n1:ns2,n1:ns2,n1:ns2)
+c
+ real ijc(n1:ns2,n1:ns2,n1:ns2)
+ real nrj(ns2),mod,pi, deuxpi,z,z0,zf,s
+ real mod0, modf,ct,t0
+ real ru(n,n,n),rv(n,n,n),rw(n,n,n)
+ complex wk(ns2+1,n,n)
+c
+ pi=acos(-1.0)
+ deuxpi=pi+pi
+ deuxpi3=(deuxpi)*(deuxpi)*(deuxpi)
+ ct=2/3
+
+c open(11,FILE='v128000.ux',
+c 1 FORM='unformatted', convert='big_endian',
+c 1 status='old')
+c read(11) (((ru(i,j,k),i=1,n),j=1,n),k=1,n)
+c close(11)
+c
+c open(12,FILE='v128000.uy',
+c 1 FORM='unformatted', convert='big_endian',
+c 1 status='old')
+c read(12) (((rv(i,j,k),i=1,n),j=1,n),k=1,n)
+c close(12)
+c
+c open(13,FILE='v128000.uz',
+c 1 FORM='unformatted', convert='big_endian',
+c 1 status='old')
+c read(13) (((rw(i,j,k),i=1,n),j=1,n),k=1,n)
+c close(13)
+c
+c call fftw3d(ru,u,n,ns2,wk,0)
+C
+c call fftw3d(rv,v,n,ns2,wk,0)
+C
+c call fftw3d(rw,w,n,ns2,wk,0)
+c
+ open(21,FILE='vel.u',FORM='UNFORMATTED',
+ 1 convert='big_endian',
+ 1 status='old')
+ read(21)t0
+ read(21) (((u(i,j,k),i=0,ns2),j=n1,ns2),k=n1,ns2)
+ close(21)
+ open(22,FILE='vel.v',FORM='UNFORMATTED',
+ 1 convert='big_endian',
+ 1 status='old')
+ read(22) (((v(i,j,k),i=0,ns2),j=n1,ns2),k=n1,ns2)
+ close(22)
+ open(23,FILE='vel.w',FORM='UNFORMATTED',
+ 1 convert='big_endian',
+ 1 status='old')
+ read(23) (((w(i,j,k),i=0,ns2),j=n1,ns2),k=n1,ns2)
+ close(23)
+c
+ do k=1-ns2,ns2
+ do j=1-ns2,ns2
+ um(0,j,k)=u(0,j,k)
+ vm(0,j,k)=v(0,j,k)
+ wm(0,j,k)=w(0,j,k)
+ do i=1,ns2
+ um(-i,j,k)=u(i,j,k)
+ um(i,j,k)=u(i,j,k)
+
+ vm(-i,j,k)=v(i,j,k)
+ vm(i,j,k)=v(i,j,k)
+c
+ wm(-i,j,k)=w(i,j,k)
+ wm(i,j,k)=w(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ open(1,file='spectreT0.97')
+ do l=1,ns2
+c
+ do k=1-ns2,ns2
+ do j=1-ns2,ns2
+ do i=1-ns2,ns2
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ mod=sqrt(ijc(i,j,k))
+ if ((mod.lt.l+0.5).and.(mod.ge.l-0.5)) then
+ z=cabs(um(i,j,k))**2+cabs(vm(i,j,k))**2+cabs(wm(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+ stop
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_balarac.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_balarac.f
new file mode 100644
index 0000000000000000000000000000000000000000..40823bb1e8182fe5ee3063c772806477bcb59603
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_balarac.f
@@ -0,0 +1,115 @@
+ program spec
+
+
+ include 'param_rho.i'
+c include 'param.h'
+
+ real*8 tout(npgx,npgy,npgz,4)
+ dimension rhog(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+ real ijc(1-ngx2:ngx2,1-ngx2:ngx2,1-ngx2:ngx2)
+ real nrj(ngx2)
+
+
+ pi=3.1415926
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=1.
+ ymax=1.
+ zmax=1.
+
+ ny2=nx2
+ nz2=nx2
+
+
+c calucl de fonction courants 3d
+
+
+ nxb=nx2/2
+ nyb=ny2/2
+ nzb=nz2/2
+
+ open(11,FILE='data1',
+ 1 FORM='binary',
+c 1 convert='big_endian',
+ 1 status='old')
+ read(11) nx,nx,nx,var
+ print*,nx,var
+ read(11) ((((tout(i,j,k,l),i=1,nx2),j=1,ny2),k=1,nz2),l=1,4)
+ close(11)
+
+ rhomax=0.
+ do i=1,nx2
+ do j=1,nx2
+ do k=1,nx2
+ rhog(i,j,k)=tout(i,j,k,4)
+ rhomax=amax1(rhomax,rhog(i,j,k))
+ enddo
+ enddo
+ enddo
+
+ open(2,file='datarho',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ write(2) ((((rhog(i,j,k)),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+
+ print*, 'rhomax = ',rhomax
+ close(2)
+
+
+ call fftw3d(rhog,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,0)
+
+
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ cfx(0,j,k)=cux(0,j,k)
+ do i=1,nxb
+ if (i.le.nxb-1) cfx(-i,j,k)=cux(i,j,k)
+ cfx(i,j,k)=cux(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ open(1,file='spectre')
+ s=0.
+ do l=1,nxb
+c
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ do i=1-nxb,nxb
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ xmod=sqrt(ijc(i,j,k))
+ if ((xmod.lt.l+0.5).and.(xmod.ge.l-0.5)) then
+ z=cabs(cfx(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_energy.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_energy.f
new file mode 100644
index 0000000000000000000000000000000000000000..1710a071219bb162f1e9575b666296bbf77611f5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_energy.f
@@ -0,0 +1,145 @@
+ program spec
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension aux3(npgx,npgy,npgz),
+ 1 aux1(npgx,npgy,npgz),aux2(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cux(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+ real ijc(1-ngx2:ngx2,1-ngx2:ngx2,1-ngx2:ngx2)
+ real nrj(ngx2)
+
+
+
+ pi=3.1415926
+ pi2=2*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ ymax=pi2
+ zmax=pi2
+
+ ny1=nx1
+ nz1=nx1
+
+c calucl de fonction courants 3d
+
+ nxb=nx1/2
+ nyb=ny1/2
+ nzb=nz1/2
+
+ open(11,FILE='omx',
+ 1 FORM='unformatted', convert='big_endian',
+ 1 status='old')
+ read(11) (((omg1(i,j,k),i=1,nx1),j=1,ny1),k=1,nz1)
+ close(11)
+
+ open(12,FILE='omy',
+ 1 FORM='unformatted', convert='big_endian',
+ 1 status='old')
+ read(12) (((omg2(i,j,k),i=1,nx1),j=1,ny1),k=1,nz1)
+ close(12)
+
+ open(13,FILE='omz',
+ 1 FORM='unformatted', convert='big_endian',
+ 1 status='old')
+ read(13) (((omg3(i,j,k),i=1,nx1),j=1,ny1),k=1,nz1)
+ close(13)
+
+ print*,'hello'
+
+ call fftw3d(omg1,cfx,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg2,cfy,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg3,cfz,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+
+ print*,'hello'
+
+c coeff de normalisation pour laplacien en spectral
+
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nzb,nzb
+ rk=float(k)*ak
+ do 10 j=1-nyb,nyb
+ rj=float(j)*aj
+ do 10 i=0,nxb
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+ if (r2.ne.0.) then
+c
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ endif
+10 continue
+
+
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ do i=1,nxb
+ if (i.le.nxb-1) cux(-i,j,k)=cux(i,j,k)
+ if (i.le.nxb-1) cuy(-i,j,k)=cuy(i,j,k)
+ if (i.le.nxb-1) cuz(-i,j,k)=cuz(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ open(1,file='spectre_en')
+ do l=1,nxb
+c
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ do i=1-nxb,nxb
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ xmod=sqrt(ijc(i,j,k))
+ if ((xmod.lt.l+0.5).and.(xmod.ge.l-0.5)) then
+ z=cabs(cux(i,j,k))**2+cabs(cuy(i,j,k))**2+cabs(cuz(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+
+
+
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho.f
new file mode 100644
index 0000000000000000000000000000000000000000..d62a5847413614995feecd756c44fd8017285a0c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho.f
@@ -0,0 +1,107 @@
+ program spec
+
+
+ include 'param_rho.i'
+ include 'param.h'
+
+ dimension rhog(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+ real ijc(1-ngx2:ngx2,1-ngx2:ngx2,1-ngx2:ngx2)
+ real nrj(ngx2)
+
+
+ pi=3.1415926
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=1.
+ ymax=1.
+ zmax=1.
+
+ ny2=nx2
+ nz2=nx2
+
+
+c calucl de fonction courants 3d
+
+
+ nxb=nx2/2
+ nyb=ny2/2
+ nzb=nz2/2
+
+ open(11,FILE='rho')
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ read(11,*) rhog(i,j,k)
+ enddo
+ enddo
+ enddo
+ close(11)
+
+ rhomax=0.
+
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ rhomax=amax1(rhomax,abs(rhog(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*,'rhomax',rhomax
+
+ call fftw3d(rhog,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,0)
+
+
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ cfx(0,j,k)=cux(0,j,k)
+ do i=1,nxb
+ if (i.le.nxb-1) cfx(-i,j,k)=cux(i,j,k)
+ cfx(i,j,k)=cux(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ open(1,file='spectre')
+
+ s=0.
+ do l=1,nxb
+c
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ do i=1-nxb,nxb
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ xmod=sqrt(ijc(i,j,k))
+ if ((xmod.lt.l+0.5).and.(xmod.ge.l-0.5)) then
+ z=cabs(cfx(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho_orig.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho_orig.f
new file mode 100644
index 0000000000000000000000000000000000000000..3094bf429d5cdcfb4781a08ef6fb42aa01c65533
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/spec_rho_orig.f
@@ -0,0 +1,104 @@
+ program spec
+
+
+ include 'param_rho.i'
+ include 'param.h'
+
+ dimension rhog(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(1-ngx2:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+ real ijc(1-ngx2:ngx2,1-ngx2:ngx2,1-ngx2:ngx2)
+ real nrj(ngx2)
+
+
+ pi=3.1415926
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=1.
+ ymax=1.
+ zmax=1.
+
+ ny2=nx2
+ nz2=nx2
+
+
+c calucl de fonction courants 3d
+
+
+ nxb=nx2/2
+ nyb=ny2/2
+ nzb=nz2/2
+
+ open(11,FILE='rho',
+ 1 FORM='unformatted', convert='big_endian',
+ 1 status='old')
+ read(11) (((rhog(i,j,k),i=1,nx2),j=1,ny2),k=1,nz2)
+ close(11)
+
+ rhomax=0.
+
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ rhomax=amax1(rhomax,abs(rhog(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*,'rhomax',rhomax
+
+ call fftw3d(rhog,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,0)
+ call fftw3d(rhog,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,0)
+
+
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ cfx(0,j,k)=cux(0,j,k)
+ do i=1,nxb
+ if (i.le.nxb-1) cfx(-i,j,k)=cux(i,j,k)
+ cfx(i,j,k)=cux(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ open(1,file='spectre')
+
+ s=0.
+ do l=1,nxb
+c
+ do k=1-nzb,nzb
+ do j=1-nyb,nyb
+ do i=1-nxb,nxb
+ ijc(i,j,k)=float(i**2+j**2+k**2)
+ xmod=sqrt(ijc(i,j,k))
+ if ((xmod.lt.l+0.5).and.(xmod.ge.l-0.5)) then
+ z=cabs(cfx(i,j,k))**2
+ s=s+z
+ endif
+ enddo
+ enddo
+ enddo
+c
+ nrj(l)=s
+c
+ write(1,*)l,nrj(l)/2
+ s=0.
+ enddo
+ close(1)
+c
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/stension.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension.f
new file mode 100644
index 0000000000000000000000000000000000000000..7640c3f4f6831a88b40544dd86f31986d623d5bc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension.f
@@ -0,0 +1,126 @@
+ subroutine stension(tau,ic)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension gradrhox(npg,npg,npg),anormx(npg,npg,npg)
+ dimension gradrhoy(npg,npg,npg),anormy(npg,npg,npg)
+ dimension gradrhoz(npg,npg,npg),anormz(npg,npg,npg)
+ dimension curv(npg,npg,npg)
+
+
+
+ pi=3.1415926
+ spi=sqrt(pi)
+ phibar=0.5
+
+ taudxinv=tau/(float(ic)*(2.*dx)**3)
+ al=0.
+
+! cas ou on ne passe pas par stretch d'abor:
+
+ goto 1111
+ do k=1,nx
+ do j=1,nx
+ do i=1,nx
+ strg1(i,j,k)=0.
+ strg2(i,j,k)=0.
+ strg3(i,j,k)=0.
+ enddo
+ enddo
+ enddo
+1111 continue
+
+c cas ou on utilise grd rho comme level set
+ eps=2.*float(ic)*dx
+ eps2=eps**2
+
+! calcul de gradrho et normale
+
+ do i=1,nx
+ it=mod(i+ic+nx-1,nx)+1
+ ib=mod(i-ic+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+ic+nx-1,nx)+1
+ jb=mod(j-ic+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+ic+nx-1,nx)+1
+ kb=mod(k-ic+nx-1,nx)+1
+ gradrhoz(i,j,k)=ug(i,j,kt)-ug(i,j,kb)
+ gradrhoy(i,j,k)=ug(i,jt,k)-ug(i,jb,k)
+ gradrhox(i,j,k)=ug(it,j,k)-ug(ib,j,k)
+ gradrho=sqrt(gradrhox(i,j,k)**2
+ & +gradrhoy(i,j,k)**2+gradrhoz(i,j,k)**2)
+ anormx(i,j,k)=0.
+ anormy(i,j,k)=0.
+ anormz(i,j,k)=0.
+ if ((abs(ug(i,j,k)-0.5).lt.0.1).or.(gradrho.ge.0.00001)) then
+ anormx(i,j,k)=gradrhox(i,j,k)/gradrho
+ anormy(i,j,k)=gradrhoy(i,j,k)/gradrho
+ anormz(i,j,k)=gradrhoz(i,j,k)/gradrho
+ endif
+c al=al+gradrho
+ enddo
+ enddo
+ enddo
+
+! calcul de courbure x gradrho
+
+ do i=1,nx
+ it=mod(i+1+nx-1,nx)+1
+ ib=mod(i-1+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+1+nx-1,nx)+1
+ jb=mod(j-1+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+1+nx-1,nx)+1
+ kb=mod(k-1+nx-1,nx)+1
+ acurv=anormx(it,j,k)-anormx(ib,j,k)
+ acurv=acurv+anormy(i,jt,k)-anormy(i,jb,k)
+ acurv=acurv+anormz(i,j,kt)-anormz(i,j,kb)
+ gradrhox(i,j,k)=gradrhox(i,j,k)*acurv
+ gradrhoy(i,j,k)=gradrhoy(i,j,k)*acurv
+ gradrhoz(i,j,k)=gradrhoz(i,j,k)*acurv
+! curv(i,j,k)=acurv
+ enddo
+ enddo
+ enddo
+
+! curl de tension superificielle
+
+ strmax=0.
+ do i=1,nx
+ it=mod(i+1+nx-1,nx)+1
+ ib=mod(i-1+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+1+nx-1,nx)+1
+ jb=mod(j-1+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+1+nx-1,nx)+1
+ kb=mod(k-1+nx-1,nx)+1
+ strg1(i,j,k)=strg1(i,j,k)-
+ & (gradrhoz(i,jt,k)-gradrhoz(i,jb,k))*taudxinv
+ & +(gradrhoy(i,j,kt)-gradrhoy(i,j,kb))*taudxinv
+ strg2(i,j,k)=strg2(i,j,k)-
+ & (gradrhox(i,j,kt)-gradrhox(i,j,kb))*taudxinv
+ & +(gradrhoz(it,j,k)-gradrhoz(ib,j,k))*taudxinv
+ strg3(i,j,k)=strg3(i,j,k)-
+ & (gradrhoy(it,j,k)-gradrhoy(ib,j,k))*taudxinv
+ & +(gradrhox(i,jt,k)-gradrhox(i,jb,k))*taudxinv
+ strmax=amax1(strmax,abs(strg1(i,j,k)))
+ strmax=amax1(strmax,abs(strg2(i,j,k)))
+ strmax=amax1(strmax,abs(strg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'STRMAX ',strmax
+112 continue
+
+c al=al*dx*dx*dx/eps
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_fourier.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_fourier.f
new file mode 100644
index 0000000000000000000000000000000000000000..7d5fda83e0b6a1d0a036c47cea4a61bcb63e074b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_fourier.f
@@ -0,0 +1,128 @@
+ subroutine stension(tau,ic)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension gradrhox(npg,npg,npg),anormx(npg,npg,npg)
+ dimension gradrhoy(npg,npg,npg),anormy(npg,npg,npg)
+ dimension gradrhoz(npg,npg,npg),anormz(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+
+ pi=3.1415926
+ spi=sqrt(pi)
+ phibar=0.5
+
+ taudxinv=tau/(float(ic)*(2.*dx)**2)
+ al=0.
+
+ nx1=nx
+ ny1=nx
+ nz1=nx
+
+
+c cas ou on utilise grd rho comme level set
+ eps=2.*float(ic)*dx
+ eps2=eps**2
+
+! calcul de gradrho et normale
+
+ do i=1,nx
+ it=mod(i+ic+nx-1,nx)+1
+ ib=mod(i-ic+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+ic+nx-1,nx)+1
+ jb=mod(j-ic+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+ic+nx-1,nx)+1
+ kb=mod(k-ic+nx-1,nx)+1
+ gradrhoz(i,j,k)=ug(i,j,kt)-ug(i,j,kb)
+ gradrhoy(i,j,k)=ug(i,jt,k)-ug(i,jb,k)
+ gradrhox(i,j,k)=ug(it,j,k)-ug(ib,j,k)
+ gradrho=sqrt(gradrhox(i,j,k)**2
+ & +gradrhoy(i,j,k)**2+gradrhoz(i,j,k)**2)
+ anormx(i,j,k)=0.
+ anormy(i,j,k)=0.
+ anormz(i,j,k)=0.
+ if ((abs(ug(i,j,k)-0.5).lt.0.4).or.(gradrho.ge.0.00001)) then
+ anormx(i,j,k)=gradrhox(i,j,k)/gradrho
+ anormy(i,j,k)=gradrhoy(i,j,k)/gradrho
+ anormz(i,j,k)=gradrhoz(i,j,k)/gradrho
+ endif
+c al=al+gradrho
+ enddo
+ enddo
+ enddo
+
+! calcul de courbure x gradrho
+
+ do i=1,nx
+ it=mod(i+1+nx-1,nx)+1
+ ib=mod(i-1+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+1+nx-1,nx)+1
+ jb=mod(j-1+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+1+nx-1,nx)+1
+ kb=mod(k-1+nx-1,nx)+1
+ acurv=anormx(it,j,k)-anormx(ib,j,k)
+ acurv=acurv+anormy(i,jt,k)-anormy(i,jb,k)
+ acurv=acurv+anormz(i,j,kt)-anormz(i,j,kb)
+ gradrhox(i,j,k)=gradrhox(i,j,k)*acurv*taudxinv
+ gradrhoy(i,j,k)=gradrhoy(i,j,k)*acurv*taudxinv
+ gradrhoz(i,j,k)=gradrhoz(i,j,k)*acurv*taudxinv
+ enddo
+ enddo
+ enddo
+
+! curl de tension superificielle
+! en fourier
+
+ nxb=nx1/2
+ nyb=ny1/2
+ nzb=nz1/2
+
+ call fftw3d(gradrhox,cfx,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(gradrhoy,cfy,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(gradrhoz,cfz,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nzb,nzb
+ rk=float(k)*ak
+ do 10 j=1-nyb,nyb
+ rj=float(j)*aj
+ do 10 i=0,nxb
+ ri=float(i)*ai
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))
+10 continue
+
+
+ call fftw3d(strg1,cux,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+ call fftw3d(strg2,cuy,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+ call fftw3d(strg3,cuz,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_old.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_old.f
new file mode 100644
index 0000000000000000000000000000000000000000..7640c3f4f6831a88b40544dd86f31986d623d5bc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/stension_old.f
@@ -0,0 +1,126 @@
+ subroutine stension(tau,ic)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension gradrhox(npg,npg,npg),anormx(npg,npg,npg)
+ dimension gradrhoy(npg,npg,npg),anormy(npg,npg,npg)
+ dimension gradrhoz(npg,npg,npg),anormz(npg,npg,npg)
+ dimension curv(npg,npg,npg)
+
+
+
+ pi=3.1415926
+ spi=sqrt(pi)
+ phibar=0.5
+
+ taudxinv=tau/(float(ic)*(2.*dx)**3)
+ al=0.
+
+! cas ou on ne passe pas par stretch d'abor:
+
+ goto 1111
+ do k=1,nx
+ do j=1,nx
+ do i=1,nx
+ strg1(i,j,k)=0.
+ strg2(i,j,k)=0.
+ strg3(i,j,k)=0.
+ enddo
+ enddo
+ enddo
+1111 continue
+
+c cas ou on utilise grd rho comme level set
+ eps=2.*float(ic)*dx
+ eps2=eps**2
+
+! calcul de gradrho et normale
+
+ do i=1,nx
+ it=mod(i+ic+nx-1,nx)+1
+ ib=mod(i-ic+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+ic+nx-1,nx)+1
+ jb=mod(j-ic+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+ic+nx-1,nx)+1
+ kb=mod(k-ic+nx-1,nx)+1
+ gradrhoz(i,j,k)=ug(i,j,kt)-ug(i,j,kb)
+ gradrhoy(i,j,k)=ug(i,jt,k)-ug(i,jb,k)
+ gradrhox(i,j,k)=ug(it,j,k)-ug(ib,j,k)
+ gradrho=sqrt(gradrhox(i,j,k)**2
+ & +gradrhoy(i,j,k)**2+gradrhoz(i,j,k)**2)
+ anormx(i,j,k)=0.
+ anormy(i,j,k)=0.
+ anormz(i,j,k)=0.
+ if ((abs(ug(i,j,k)-0.5).lt.0.1).or.(gradrho.ge.0.00001)) then
+ anormx(i,j,k)=gradrhox(i,j,k)/gradrho
+ anormy(i,j,k)=gradrhoy(i,j,k)/gradrho
+ anormz(i,j,k)=gradrhoz(i,j,k)/gradrho
+ endif
+c al=al+gradrho
+ enddo
+ enddo
+ enddo
+
+! calcul de courbure x gradrho
+
+ do i=1,nx
+ it=mod(i+1+nx-1,nx)+1
+ ib=mod(i-1+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+1+nx-1,nx)+1
+ jb=mod(j-1+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+1+nx-1,nx)+1
+ kb=mod(k-1+nx-1,nx)+1
+ acurv=anormx(it,j,k)-anormx(ib,j,k)
+ acurv=acurv+anormy(i,jt,k)-anormy(i,jb,k)
+ acurv=acurv+anormz(i,j,kt)-anormz(i,j,kb)
+ gradrhox(i,j,k)=gradrhox(i,j,k)*acurv
+ gradrhoy(i,j,k)=gradrhoy(i,j,k)*acurv
+ gradrhoz(i,j,k)=gradrhoz(i,j,k)*acurv
+! curv(i,j,k)=acurv
+ enddo
+ enddo
+ enddo
+
+! curl de tension superificielle
+
+ strmax=0.
+ do i=1,nx
+ it=mod(i+1+nx-1,nx)+1
+ ib=mod(i-1+nx-1,nx)+1
+ do j=1,nx
+ jt=mod(j+1+nx-1,nx)+1
+ jb=mod(j-1+nx-1,nx)+1
+ do k=1,nx
+ kt=mod(k+1+nx-1,nx)+1
+ kb=mod(k-1+nx-1,nx)+1
+ strg1(i,j,k)=strg1(i,j,k)-
+ & (gradrhoz(i,jt,k)-gradrhoz(i,jb,k))*taudxinv
+ & +(gradrhoy(i,j,kt)-gradrhoy(i,j,kb))*taudxinv
+ strg2(i,j,k)=strg2(i,j,k)-
+ & (gradrhox(i,j,kt)-gradrhox(i,j,kb))*taudxinv
+ & +(gradrhoz(it,j,k)-gradrhoz(ib,j,k))*taudxinv
+ strg3(i,j,k)=strg3(i,j,k)-
+ & (gradrhoy(it,j,k)-gradrhoy(ib,j,k))*taudxinv
+ & +(gradrhox(i,jt,k)-gradrhox(i,jb,k))*taudxinv
+ strmax=amax1(strmax,abs(strg1(i,j,k)))
+ strmax=amax1(strmax,abs(strg2(i,j,k)))
+ strmax=amax1(strmax,abs(strg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'STRMAX ',strmax
+112 continue
+
+c al=al*dx*dx*dx/eps
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/stretch_freeb.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/stretch_freeb.f
new file mode 100644
index 0000000000000000000000000000000000000000..6b27b6ca422d6c2a36ea31b4b5715fcd4b3737b4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/stretch_freeb.f
@@ -0,0 +1,77 @@
+ subroutine stretch_freeb(drho)
+
+! terme de stretching 3D sur grille + forcing du a densite variable
+! dans approx de Bouss.
+! gravite orientee selon axe des x
+! la densite est recuperee du scalaire ug
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dy1=dx1
+ dz1=dx1
+
+ dxinv=1./(12.*dx1)
+ dyinv=1./(12.*dy1)
+ dzinv=1./(12.*dz1)
+
+ do k=1,nz1
+ kt=mod(k+nz1,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ ktt=mod(k+1+nz1,nz1)+1
+ kbb=mod(k-3+nz1,nz1)+1
+cc
+ do j=1,ny1
+ jt=mod(j+ny1,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ jtt=mod(j+1+ny1,ny1)+1
+ jbb=mod(j-3+ny1,ny1)+1
+cc
+ do i=1,nx1
+ it=mod(i+nx1,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ itt=mod(i+1+nx1,nx1)+1
+ ibb=mod(i-3+nx1,nx1)+1
+
+c
+ aux1=omg1(itt,j,k)*vxg(itt,j,k)+8.*(omg1(ib,j,k)*vxg(ib,j,k)-
+ 1 omg1(it,j,k)*vxg(it,j,k))-omg1(ibb,j,k)*vxg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vxg(i,jtt,k)+8.*(omg2(i,jb,k)*vxg(i,jb,k)-
+ 1 omg2(i,jt,k)*vxg(i,jt,k))-omg2(i,jbb,k)*vxg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vxg(i,j,ktt)+8.*(omg3(i,j,kb)*vxg(i,j,kb)-
+ 1 omg3(i,j,kt)*vxg(i,j,kt))-omg3(i,j,kbb)*vxg(i,j,kbb)
+
+ strg1(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+c
+ aux1=omg1(itt,j,k)*vyg(itt,j,k)+8.*(omg1(ib,j,k)*vyg(ib,j,k)-
+ 1 omg1(it,j,k)*vyg(it,j,k))-omg1(ibb,j,k)*vyg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vyg(i,jtt,k)+8.*(omg2(i,jb,k)*vyg(i,jb,k)-
+ 1 omg2(i,jt,k)*vyg(i,jt,k))-omg2(i,jbb,k)*vyg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vyg(i,j,ktt)+8.*(omg3(i,j,kb)*vyg(i,j,kb)-
+ 1 omg3(i,j,kt)*vyg(i,j,kt))-omg3(i,j,kbb)*vyg(i,j,kbb)
+
+ strg2(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+! terme venant de densite varaible
+ aux=ug(i,j,ktt)+8*(ug(i,j,kb)-ug(i,j,kt))-ug(i,j,kbb)
+ strg2(i,j,k)=strg2(i,j,k)-drho*aux*dzinv
+!
+ aux1=omg1(itt,j,k)*vzg(itt,j,k)+8.*(omg1(ib,j,k)*vzg(ib,j,k)-
+ 1 omg1(it,j,k)*vzg(it,j,k))-omg1(ibb,j,k)*vzg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vzg(i,jtt,k)+8.*(omg2(i,jb,k)*vzg(i,jb,k)-
+ 1 omg2(i,jt,k)*vzg(i,jt,k))-omg2(i,jbb,k)*vzg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vzg(i,j,ktt)+8.*(omg3(i,j,kb)*vzg(i,j,kb)-
+ 1 omg3(i,j,kt)*vzg(i,j,kt))-omg3(i,j,kbb)*vzg(i,j,kbb)
+
+ strg3(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+! terme venant de densite varaible
+ aux=ug(i,jtt,k)+8*(ug(i,jb,k)-ug(i,jt,k))-ug(i,jbb,k)
+ strg3(i,j,k)=strg3(i,j,k)+drho*aux*dyinv
+
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..dcaa28c012cfbf8d2e0619ef4d6905dd6456e260
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l2.f
@@ -0,0 +1,181 @@
+ subroutine tag_particles(npart,npart_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ include 'param.i'
+ include 'param.h'
+
+ common/remesh/xp(npg),xp1(npg),up(npg),vx(npg)
+
+ integer icfl(*),itype(*),itype_aux(*),itag(*)
+ dimension xp_aux(*),up_aux(*),vx_aux(*)
+
+ integer ntype(npg),ncfl(npg),npart_bl(npg),i_nbl(npg)
+ dimension amin_lambda(npg)
+
+
+c ntype(nbl) : type de bloc (1=centre ou 0=left) pour choix de la formule
+c remaillage
+c itype(npart) : idem pour les particules de ces blocks
+c ncfl(nbl)=cfl-nint ou cfl-int selon le type
+c icfl(npart) : idem pour particules de cs blocks
+c xp_aux(npart_aux): particles inside the blocks, for plain remeshing
+c itype_aux(npart_aux) : type de block pour ces particules
+c ntag: number of tagged particles, for special remeshing
+c itag(ntag): pointer for tagged particles
+c i_nbl(nbl) indice de la derniere particule du bloc nbl
+
+c cfl=delt/dx
+
+ x0=xmin
+
+
+ m=np_bl+1
+ nblock=nx/(m)
+ dx_bl=float(m)*dx
+ dx_bl_inv=1./dx_bl
+
+c on range les partucles par block
+c et on calcule lambda moyen pour chaque block
+
+ do nbl=1,nblock
+ amin_lambda(nbl)=111.
+ npart_bl(nbl)=0
+ i_nbl(nbl)=0
+ enddo
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(i)*cfl)
+ npart_bl(nbl)=npart_bl(nbl)+1
+ i_nbl(nbl)=i
+ enddo
+
+c on ajoute la particule a droite du bloc (si elle existe) pour calculer
+c le amin_lambda, pour eviter pbms a l'interface entre blocs de meme type
+c (a corriger: pour l'instant je ne regarde pas le dernier bloc avec xp(1)
+
+ do nbl=1,nblock-1
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((ii.lt.npart).and.(xp(ii+1).lt.xp(ii)+1.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+ enddo
+
+c le dernier bloc (a la main ..)
+
+ nbl=nblock
+ if (i_nbl(nbl).ne.0) then
+ if ((xp(npart).ge.xmax-1.5*dx).and.(xp(1).lt.xmin+0.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(1)*cfl)
+ endif
+ endif
+
+
+c et on en deduit type de block (1=centre vs 0=left) et l'indice du bloc
+
+
+ do nbl=1,nblock
+ if (amin_lambda(nbl).lt.nint(amin_lambda(nbl))) then
+ ntype(nbl)=1
+ ncfl(nbl)=nint(amin_lambda(nbl))
+ else
+ ntype(nbl)=0
+ ncfl(nbl)=int(amin_lambda(nbl))
+ if (amin_lambda(nbl).lt.0) ncfl(nbl)=int(amin_lambda(nbl))-1
+ endif
+
+c print*,'nbl et type',nbl, ntype(nbl),amin_lambda(nbl)
+ enddo
+c
+c on affecte le type et l'indice cfl du bloc sur ses particules
+
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ itype(i)=ntype(nbl)
+ icfl(i)=ncfl(nbl)
+c print*,'nbl et type',nbl,i, itype(i),icfl(i)
+ enddo
+
+
+c on tagge les particules entre les blocs successifs non vides qui:
+c sont de type et indice cfl differents
+c (cases b,c,b',c' du papier)
+
+ ntag=0
+ npart_aux=0
+ j=2
+ jc=0
+ do i=2,npart-1
+ j=j+jc
+ if (j.ge.npart) go to 111
+ jj=j+1
+c print*,j,icfl(j),icfl(jj),itype(j),itype(jj)
+ if ((icfl(j).ne.icfl(jj)).and.(itype(j).ne.itype(jj))
+ 1 .and.(xp(jj).le.xp(j)+1.5*dx)) then
+ ntag=ntag+1
+ itag(ntag)=j
+ ntag=ntag+1
+ itag(ntag)=j+1
+c print*,' **** TAGGED ',j,xp(j),itype(j),icfl(j),vx(j)*delt/dx,
+c 1 nint(vx(j)*delt/dx)
+c print*,' **** TAGGED ',jj,xp(jj),itype(jj),icfl(jj),vx(jj)*delt/dx,
+c 1 nint(vx(jj)*delt/dx)
+ jc=2
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(j)
+ up_aux(npart_aux)=up(j)
+ vx_aux(npart_aux)=vx(j)
+ itype_aux(npart_aux)=itype(j)
+c print*,'REGULAR',npart_aux,xp_aux(npart_aux),up_aux(npart_aux)
+c 1 ,vx_aux(j)*delt/dx,icfl(j)
+ jc=1
+ endif
+ enddo
+
+111 continue
+
+c on regarde a part la premiere et la derniere particule
+c (je ne sais pas faire autrement pour l'instant)
+
+ if (npart.ge.1) then
+
+ if ((icfl(1).ne.icfl(npart)).and.(itype(1).ne.itype(npart))
+ 1 .and.(xp(npart).ge.xp(1)+(float(nx)-1.5)*dx)
+ 1 .and.(itag(ntag).ne.npart)) then
+c 1 ) then
+ ntag=ntag+1
+ itag(ntag)=npart
+ ntag=ntag+1
+ itag(ntag)=1
+c print*,' TAGGED ',j,xp(j),icfl(j)
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(1)
+ up_aux(npart_aux)=up(1)
+ vx_aux(npart_aux)=vx(1)
+ itype_aux(npart_aux)=itype(1)
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ if (npart.gt.1) then
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(npart)
+ up_aux(npart_aux)=up(npart)
+ vx_aux(npart_aux)=vx(npart)
+ itype_aux(npart_aux)=itype(npart)
+ endif
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ endif
+
+ endif
+
+
+
+! if (ntag.ne.0) print*,'npart,NTAG, NPART_AUX = ',npart,ntag,npart_aux
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..e0c1334fb5ce1d0e6c14cbf28877cc4ddd31f635
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_l4.f
@@ -0,0 +1,147 @@
+ subroutine tag_particles(npart,npart_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ include 'param.i'
+ include 'param.h'
+
+ common/remesh/xp(npg),xp1(npg),up(npg),vx(npg)
+
+ integer icfl(*),itype(*),itype_aux(*),itag(*)
+ dimension xp_aux(*),up_aux(*),vx_aux(*)
+
+ integer ntype(npg),ncfl(npg),npart_bl(npg),i_nbl(npg)
+ dimension amin_lambda(npg)
+
+
+c ntype(nbl) : type de bloc (1=centre ou 0=left) pour choix de la formule
+c remaillage
+c itype(npart) : idem pour les particules de ces blocks
+c ncfl(nbl)=cfl-nint ou cfl-int selon le type
+c icfl(npart) : idem pour particules de cs blocks
+c xp_aux(npart_aux): particles inside the blocks, for plain remeshing
+c itype_aux(npart_aux) : type de block pour ces particules
+c ntag: number of tagged particles, for special remeshing
+c itag(ntag): pointer for tagged particles
+c i_nbl(nbl) indice de la derniere particule du bloc nbl
+
+ x0=xmin
+
+ m=np_bl+1
+ nblock=nx/(m)
+ dx_bl=float(m)*dx
+ dx_bl_inv=1./dx_bl
+
+c on range les partucles par block
+c et on calcule lambda moyen pour chaque block
+
+ do nbl=1,nblock
+ amin_lambda(nbl)=111.
+ npart_bl(nbl)=0
+ i_nbl(nbl)=0
+ enddo
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.0001)*dx_bl_inv)
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(i)*cfl)
+ npart_bl(nbl)=npart_bl(nbl)+1
+ i_nbl(nbl)=i
+ enddo
+
+c on ajoute la particule a droite du bloc (si elle existe) pour calculer
+c le amin_lambda, pour eviter pbms a l'interface entre blocs de meme type
+c (a corriger: pour l'instant je ne regarde pas le dernier bloc avec xp(1)
+
+ do nbl=1,nblock-1
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((ii.lt.npart).and.(xp(ii+1).lt.xp(ii)+1.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+! print*, 'TYPES ',nbl,ii,amin_lambda(nbl)
+ enddo
+
+c le dernier bloc (a la main ..)
+
+ nbl=nblock
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((xp(ii).ge.xmax-1.5*dx).and.(xp(ii+1).lt.xmin+0.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+
+
+c et on en deduit type de block (1=centre vs 0=left) et l'indice du bloc
+
+
+ do nbl=1,nblock
+ if (amin_lambda(nbl).lt.nint(amin_lambda(nbl))) then
+ ntype(nbl)=1
+ ncfl(nbl)=nint(amin_lambda(nbl))
+ else
+ ntype(nbl)=0
+ ncfl(nbl)=int(amin_lambda(nbl))
+ if (amin_lambda(nbl).lt.0) ncfl(nbl)=int(amin_lambda(nbl))-1
+ endif
+
+c print*,'nbl et type',nbl, ntype(nbl),amin_lambda(nbl)
+ enddo
+c
+c on affecte le type et l'indice cfl du bloc sur ses particules
+
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.0001)*dx_bl_inv)
+ itype(i)=ntype(nbl)
+ icfl(i)=ncfl(nbl)
+c print*,'nbl et type',nbl,i, itype(i),icfl(i)
+ enddo
+
+
+c on tagge les particules entre les blocs successifs non vides qui: dfdsfdfdfsdsdffsdfsdfsdfsdfsdfsdf
+c sont de type et indice cfl differents
+c (cases b,c,b',c' du papier)
+
+ ntag=0
+ npart_aux=0
+ j=1
+ jc=0
+ do i=1,npart
+ j=j+jc
+ if (j.gt.npart) go to 111
+ j1=j
+ jj=j+1
+ jjj=j+2
+ if ((jjj.le.npart).and.(icfl(jj).ne.icfl(jjj))
+ 1 .and.(itype(jj).ne.itype(jjj))
+ 1 .and.(xp(jjj).le.xmin+amod(xp(jj)+1.5*dx-xmin,xmax-xmin))) then
+ ntag=ntag+1
+ itag(ntag)=j1
+ ntag=ntag+1
+ itag(ntag)=jj
+ ntag=ntag+1
+ itag(ntag)=jjj
+ ntag=ntag+1
+ itag(ntag)=j+3
+ jc=4
+! cprint*,'tags',ntag,j1,jj,jjj,j+3
+! print*,' Blocs', itype(jj),icfl(jj),itype(jjj),icfl(jjj)
+! print*,xp(jj),xp(jjj)
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(j1)
+ up_aux(npart_aux)=up(j1)
+ vx_aux(npart_aux)=vx(j1)
+ itype_aux(npart_aux)=itype(j1)
+ jc=1
+ endif
+ enddo
+
+111 continue
+ if (npart_aux+ntag.ne.npart) print*,'ATT**',j,npart_aux,ntag,jc
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..333f22fd328b278d066f08140296c660c44032ef
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/tag_particles_limit.f
@@ -0,0 +1,185 @@
+ subroutine tag_particles(npart,npart_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux,sl,sl1,sl2)
+
+ include 'param.i'
+ include 'param.h'
+
+ common/remesh/xp(npg),xp1(npg),up(npg),vx(npg)
+
+ integer icfl(*),itype(*),itype_aux(*),itag(*)
+ dimension xp_aux(*),up_aux(*),vx_aux(*)
+ dimension sl(*),sl1(*),sl2(*)
+
+ integer ntype(npg),ncfl(npg),npart_bl(npg),i_nbl(npg)
+ dimension amin_lambda(npg)
+
+
+c ntype(nbl) : type de bloc (1=centre ou 0=left) pour choix de la formule
+c remaillage
+c itype(npart) : idem pour les particules de ces blocks
+c ncfl(nbl)=cfl-nint ou cfl-int selon le type
+c icfl(npart) : idem pour particules de cs blocks
+c xp_aux(npart_aux): particles inside the blocks, for plain remeshing
+c itype_aux(npart_aux) : type de block pour ces particules
+c ntag: number of tagged particles, for special remeshing
+c itag(ntag): pointer for tagged particles
+c i_nbl(nbl) indice de la derniere particule du bloc nbl
+
+ x0=xmin
+
+ dh=dx
+
+ m=np_bl+1
+ nblock=nx/(m)
+ dx_bl=float(m)*dh
+ dx_bl_inv=1./dx_bl
+
+c on range les partucles par block
+c et on calcule lambda moyen pour chaque block
+
+ do nbl=1,nblock
+ amin_lambda(nbl)=111.
+ npart_bl(nbl)=0
+ i_nbl(nbl)=0
+ enddo
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(i)*cfl)
+ npart_bl(nbl)=npart_bl(nbl)+1
+ i_nbl(nbl)=i
+ enddo
+
+c on ajoute la particule a droite du bloc (si elle existe) pour calculer
+c le amin_lambda, pour eviter pbms a l'interface entre blocs de meme type
+c (a corriger: pour l'instant je ne regarde pas le dernier bloc avec xp(1)
+
+ do nbl=1,nblock-1
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((ii.lt.npart).and.(xp(ii+1).lt.xp(ii)+1.5*dh)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+ enddo
+
+c le dernier bloc (a la main ..)
+
+ nbl=nblock
+ if (i_nbl(nbl).ne.0) then
+ if ((xp(npart).ge.xmax-1.5*dh).and.(xp(1).lt.xmin+0.5*dh)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(1)*cfl)
+ endif
+ endif
+
+
+c et on en deduit type de block (1=centre vs 0=left) et l'indice du bloc
+
+
+ do nbl=1,nblock
+ if (amin_lambda(nbl).lt.nint(amin_lambda(nbl))+0.00001) then
+ ntype(nbl)=1
+ ncfl(nbl)=nint(amin_lambda(nbl))
+ else
+ ntype(nbl)=0
+ ncfl(nbl)=int(amin_lambda(nbl))
+ if (amin_lambda(nbl).lt.0) ncfl(nbl)=int(amin_lambda(nbl))-1
+ endif
+
+c print*,'nbl et type',nbl, ntype(nbl),amin_lambda(nbl)
+ enddo
+c
+c on affecte le type et l'indice cfl du bloc sur ses particules
+
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ itype(i)=ntype(nbl)
+ icfl(i)=ncfl(nbl)
+c print*,'nbl et type',nbl,i, itype(i),icfl(i)
+ enddo
+
+
+c on tagge les particules entre les blocs successifs non vides qui:
+c sont de type et indice cfl differents
+c (cases b,c,b',c' du papier)
+
+ ntag=0
+ npart_aux=0
+ j=2
+ jc=0
+ do i=2,npart-1
+ j=j+jc
+ if (j.ge.npart) go to 111
+ jj=j+1
+c print*,j,icfl(j),icfl(jj),itype(j),itype(jj)
+ if ((icfl(j).ne.icfl(jj)).and.(itype(j).ne.itype(jj))
+ 1 .and.(xp(jj).le.xp(j)+1.5*dh)) then
+ ntag=ntag+1
+ itag(ntag)=j
+ ntag=ntag+1
+ itag(ntag)=j+1
+c print*,' **** TAGGED ',j,xp(j),itype(j),icfl(j),vx(j)*delt/dh,
+c 1 nint(vx(j)*delt/dh)
+c print*,' **** TAGGED ',jj,xp(jj),itype(jj),icfl(jj),vx(jj)*delt/dh,
+c 1 nint(vx(jj)*delt/dh)
+ jc=2
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(j)
+ up_aux(npart_aux)=up(j)
+ vx_aux(npart_aux)=vx(j)
+ sl1(npart_aux)=sl(j)
+ sl2(npart_aux)=sl(j-1)
+ itype_aux(npart_aux)=itype(j)
+c print*,'REGULAR',npart_aux,xp_aux(npart_aux),up_aux(npart_aux)
+c 1 ,vx_aux(j)*delt/dh,icfl(j)
+ jc=1
+ endif
+ enddo
+
+111 continue
+
+c on regarde a part la premiere et la derniere particule
+c (je ne sais pas faire autrement pour l'instant)
+
+ if (npart.ge.1) then
+
+ if ((icfl(1).ne.icfl(npart)).and.(itype(1).ne.itype(npart))
+ 1 .and.(xp(npart).ge.xp(1)+(float(nx)-1.5)*dh)
+ 1 .and.(itag(ntag).ne.npart)) then
+c 1 ) then
+ ntag=ntag+1
+ itag(ntag)=npart
+ ntag=ntag+1
+ itag(ntag)=1
+c print*,' TAGGED ',j,xp(j),icfl(j)
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(1)
+ up_aux(npart_aux)=up(1)
+ vx_aux(npart_aux)=vx(1)
+ sl1(npart_aux)=sl(1)
+ sl2(npart_aux)=sl(npart)
+ itype_aux(npart_aux)=itype(1)
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ if (npart.gt.1) then
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(npart)
+ up_aux(npart_aux)=up(npart)
+ vx_aux(npart_aux)=vx(npart)
+ sl1(npart_aux)=sl(npart)
+ sl2(npart_aux)=sl(npart-1)
+ itype_aux(npart_aux)=itype(npart)
+ endif
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ endif
+
+ endif
+
+! print*,'npart,NTAG, NPART_AUX = ',npart,ntag,npart_aux
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_bar.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_bar.f
new file mode 100644
index 0000000000000000000000000000000000000000..76397872484dfe792ba14fa6dd53b04964033d5c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_bar.f
@@ -0,0 +1,119 @@
+ subroutine velox_bar(delt)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension aux3(npgx,npgy,npgz),
+ 1 aux1(npgx,npgy,npgz),aux2(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+
+ pi=3.1415926
+
+! calcu de grad rho x g
+
+ do k=1,nz2
+ kt=mod(k+nz1,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ ktt=mod(k+1+nz1,nz1)+1
+ kbb=mod(k-3+nz1,nz1)+1
+cc
+ do j=1,ny2
+ jt=mod(j+ny1,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ jtt=mod(j+1+ny1,ny1)+1
+ jbb=mod(j-3+ny1,ny1)+1
+cc
+ do i=1,nx2
+ it=mod(i+nx1,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ itt=mod(i+1+nx1,nx1)+1
+ ibb=mod(i-3+nx1,nx1)+1
+
+ aux=ug(i,j,ktt)+8*(ug(i,j,kb)-ug(i,j,kt))-ug(i,j,kbb)
+ cfy(i,j,k)=-aux*drho*delt/(12.*dx2)
+ aux=ug(i,jtt,k)+8*(ug(i,jb,k)-ug(i,jt,k))-ug(i,jbb,k)
+ cfz(i,j,k)=+aux*drho*delt/(12.*dx2)
+
+ enddo
+ enddo
+ enddo
+
+! calucl de fonction courants 3d
+
+ nxb=nx2/2
+ nyb=ny2/2
+ nzb=nz2/2
+
+c call fftw3d(omg1,cfx,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg2,cfy,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg3,cfz,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+
+c coeff de normalisation pour laplacien en spectral
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nzb,nzb
+ rk=float(k)*ak
+ do 10 j=1-nyb,nyb
+ rj=float(j)*aj
+ do 10 i=0,nxb
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+ if (r2.ne.0.) then
+c
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+c cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(ri*cfz(i,j,k))/r2
+c cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k))/r2
+ endif
+10 continue
+
+ call fftw3d(aux1,cux,nx2,ny2,nz2,nxb,nyb,nzb,wk,1)
+ call fftw3d(aux2,cuy,nx2,ny2,nz2,nxb,nyb,nzb,wk,1)
+ call fftw3d(aux3,cuz,nx2,ny2,nz2,nxb,nyb,nzb,wk,1)
+
+ vxmax=0.
+ vymax=0.
+ vzmax=0.
+ do k=1,nz1
+ do j=1,ny1
+ do i=1,nx1
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ vxmax=amax1(vxmax,abs(vxg(i,j,k)))
+ vymax=amax1(vymax,abs(vyg(i,j,k)))
+ vzmax=amax1(vzmax,abs(vzg(i,j,k)))
+ enddo
+ enddo
+ enddo
+ print*,' VXMAX sur grille ',vxmax,vymax,vzmax
+ vmax=amax1(vxmax,vymax)
+ vmax=amax1(vmax,vzmax)
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_burgers.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_burgers.f
new file mode 100644
index 0000000000000000000000000000000000000000..c4f007a008f1588de1a237eb4bd8a110f868bfe8
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/velox_burgers.f
@@ -0,0 +1,70 @@
+ subroutine velox_burgers(vxmax,dvmax)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cux,cvx,wk,wk2
+ dimension cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz),
+ 1 wk2(ngx2+1,npgy,npgz)
+
+ dimension aux2(npgx,npgy,npgz)
+
+ pi=3.1415926
+
+c Fourier
+
+ nxb=nx1/2
+ nyb=ny1/2
+ nzb=nz1/2
+
+ nxb2=nx3/2
+ nyb2=nx3/2
+ nzb2=nx3/2
+ dx3=(xmax-xmin)/float(nx3)
+
+ call fftw3d(ug,cux,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+
+c filtre lineaire
+
+ do 10 k=1-nzb,nzb
+ do 10 j=1-nyb,nyb
+ do 10 i=1,nxb
+ xi=(sin(8.*pi*i*dx3)/(8.*pi*i*dx3))**2
+ cux(i,j,k)=cux(i,j,k)*xi
+10 continue
+
+c retour ds l'espace physique
+
+ call fftw3d(aux2,cux,nx1,ny1,nz1,nxb,nyb,nzb,wk2,1)
+
+ vxmax=0.
+ dvmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ psi1(i,j,k)=aux2(i,j,k)
+ vxmax=amax1(vxmax,abs(psi1(i,j,k)))
+ enddo
+ enddo
+ enddo
+ print*,' VXMAX sur grille ',vxmax
+
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ do i=1,nx3
+c print*, psi1(1,i,1),psi1(i,2,2),psi1(i,128,128)
+ enddo
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_full.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_full.f
new file mode 100644
index 0000000000000000000000000000000000000000..2fde3090675727ccc0e1e9f8d6023bd5c4e1c4f4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_full.f
@@ -0,0 +1,112 @@
+ subroutine veloxaux(vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ parameter(npg2=32)
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ dimension aux1(npg2,npg2,npg2),aux2(npg2,npg2,npg2)
+ dimension aux3(npg2,npg2,npg2)
+
+ parameter(npgb2=npg2/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+ complex cvx,cvy,cvz,wk2
+ dimension cvx(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvy(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvz(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 wk2(npgb2+1,npg2,npg2)
+
+ pi=3.1415926
+
+ nxb2=nx3/2
+ nyb2=nx3/2
+ nzb2=nx3/2
+
+ do 10 k=1-nzb2,nzb2
+ do 10 j=1-nyb2,nyb2
+ do 10 i=0,nxb2
+ cvx(i,j,k)=cux(i,j,k)
+ cvy(i,j,k)=cuy(i,j,k)
+ cvz(i,j,k)=cuz(i,j,k)
+10 continue
+
+
+ call fftw3d(aux3,cvz,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+ call fftw3d(aux2,cvy,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+ call fftw3d(aux1,cvx,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+
+! ecriture fhciers grille NX2
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ psi1(i,j,k)=-aux1(i,j,k)
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ psi2(i,j,k)=-aux2(i,j,k)
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ psi3(i,j,k)=-aux3(i,j,k)
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+
+ print*,'umax', umax1,umax2,umax3
+ vmax=amax1(umax1,umax2,umax3)
+
+ goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(20) ((((psi1(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(21,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(21) ((((psi2(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(22,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(22) ((((psi3(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ close(20)
+ close(21)
+ close(22)
+
+111 continue
+
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_small.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_small.f
new file mode 100644
index 0000000000000000000000000000000000000000..72d58284b2b604d3791c1d425c876ec55872fde4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_small.f
@@ -0,0 +1,57 @@
+ subroutine veloxaux(vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ pi=3.1415926
+
+ dx3=2.*(xmax-xmin)/float(nx3)
+
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ pi2z=xmin+float(k-1)*dx3
+ piz=0.5*pi2z
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ pi2y=xmin+float(j-1)*dx3
+ piy=0.5*pi2y
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ pi2x=xmin+float(i-1)*dx3
+ pix=0.5*pi2x
+ psi1(i,j,k)=2.*sin(pix)*sin(pix)*sin(pi2y)*sin(pi2z)
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ psi2(i,j,k)=-sin(pi2x)*sin(piy)*sin(piy)*sin(pi2z)
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ psi3(i,j,k)=-sin(pi2x)*sin(piz)*sin(piz)*sin(pi2y)
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*,'umax', umax1,umax2,umax3
+ vmax=amax1(umax1,umax2,umax3)
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_v2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_v2.f
new file mode 100644
index 0000000000000000000000000000000000000000..adbe919d4dc50212dee44c053ad035f321097f17
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/veloxaux_v2.f
@@ -0,0 +1,140 @@
+ subroutine veloxaux(vmax,dvmax)
+
+! version de veloxaux ou on prend les 32 premiers
+! modes de la vitesse, on padde avec des 0 jusqu'a nx2 (128 ou 256)
+! et on fait fft inverse sur une grille nx2
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ parameter(npg2=128)
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ dimension aux1(npg2,npg2,npg2),aux2(npg2,npg2,npg2)
+ dimension aux3(npg2,npg2,npg2)
+
+ parameter(npgb2=npg2/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+ complex cvx,cvy,cvz,wk2
+ dimension cvx(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvy(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvz(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 wk2(npgb2+1,npg2,npg2)
+
+ pi=3.1415926
+
+ nxb2=nx3/2
+ nyb2=nx3/2
+ nzb2=nx3/2
+ nxb2=16
+ nyb2=16
+ nzb2=16
+ nxb=nx1/2
+ nyb=nx1/2
+ nzb=nx1/2
+
+ dx3=2.*(xmax-xmin)/float(nx3)
+
+ do 20 k=1-nzb,nzb
+ do 20 j=1-nyb,nyb
+ do 20 i=0,nxb
+ cvx(i,j,k)=0.
+ cvy(i,j,k)=0.
+ cvz(i,j,k)=0.
+20 continue
+
+ do 10 k=1-nzb2,nzb2
+ do 10 j=1-nyb2,nyb2
+ do 10 i=0,nxb2
+ cvx(i,j,k)=cux(i,j,k)
+ cvy(i,j,k)=cuy(i,j,k)
+ cvz(i,j,k)=cuz(i,j,k)
+10 continue
+
+c call fftw3d(aux3,cvz,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+c call fftw3d(aux2,cvy,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+c call fftw3d(aux1,cvx,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+ call fftw3d(aux3,cvz,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+ call fftw3d(aux2,cvy,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+ call fftw3d(aux1,cvx,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+
+! ecriture fhciers grille NX2
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ dvxmax=0.
+ dvymax=0.
+ dvzmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ psi1(i,j,k)=-aux1(i,j,k)
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ psi2(i,j,k)=-aux2(i,j,k)
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ psi3(i,j,k)=-aux3(i,j,k)
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvxmax=amax1(dvxmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvymax=amax1(dvymax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvzmax=amax1(dvzmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ dvmax=amax1(dvxmax,dvymax)
+ dvmax=amax1(dvmax,dvzmax)
+
+ print*,'umax', umax1,umax2,umax3
+ print*,'DVMAXs ',dvxmax,dvymax,dvzmax
+
+ vmax=amax1(umax1,umax2,umax3)
+
+ goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(20) ((((psi1(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(21,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(21) ((((psi2(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(22,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(22) ((((psi3(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ close(20)
+ close(21)
+ close(22)
+
+111 continue
+
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec.f
new file mode 100644
index 0000000000000000000000000000000000000000..0f79ca21cbd88d264d575d58c3a5344f048927d0
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec.f
@@ -0,0 +1,87 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+! initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+222 continue
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np_aux,xp_aux,up_aux,itype_aux,jr,kr)
+ if (ntag.ne.0) call remeshx_tag(ntag,itag,itype,icfl,jr,kr)
+
+! fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..f6c444ec5809a82edfe2bff43817a62e4578d76c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_corec_limit.f
@@ -0,0 +1,97 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+ dimension sl(npg),sl1(npg),sl2(npg)
+
+
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+! initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+ do n=1,np
+! vx(n)=up(n)
+! if ((j.eq.3).and.(k.eq.3)) print*,vx(n)
+ enddo
+! pentes pour limiteurs
+
+ call slopes(dt,np,sl)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux,sl,sl1,sl2)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+222 continue
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np_aux,xp_aux,up_aux,itype_aux,jr,kr,sl1,sl2)
+ if (ntag.ne.0) call remeshx_tag(ntag,itag,itype,icfl,jr,kr,sl)
+
+! fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..613a943aa54b43a30034e20ce0f12911da19ea0b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l2.f
@@ -0,0 +1,79 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+c routine d'advection en x :
+c parcours des lignes horozontales
+c intilisation de particules
+c calcul des vitesses par RK2
+c tag des particules en focntion des varaitions de cfl
+c push and remesh
+
+c cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+c 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+c initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np,xp_aux,up_aux,itype,jr,kr)
+
+c fin de ligne j,k:
+ npart=npart+np
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..cbaa3dcd4a87ce72fc8da4f7c5566319eaa1ba99
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_l4.f
@@ -0,0 +1,124 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+c routine d'advection en x :
+c parcours des lignes horozontales
+c intilisation de particules
+c calcul des vitesses par RK2
+c tag des particules en focntion des varaitions de cfl
+c push and remesh
+
+c cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ tm=0.
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+c 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ yy=xmin+float(j-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do i=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(ug(j1,j,k))+abs(ug(j2,j,k))+abs(ug(j3,j,k))
+ 1 +abs(ug(j4,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(j1,j,k)
+ tm=tm+ug(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=ug(j2,j,k)
+ tm=tm+ug(j2,j,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=ug(j3,j,k)
+ tm=tm+ug(j3,j,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=ug(j4,j,k)
+ tm=tm+ug(j4,j,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(ug(j1,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(j1,j,k)
+ tm=tm+ug(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+ if (ntag+np_aux.ne.np) print*, ntag,np_aux,np
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np_aux,xp_aux,up_aux,itype_aux,jr,kr)
+ if (ntag.ne.0) call remeshx_tag(ntag,itag,itype,icfl,jr,kr)
+
+c fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'TM debut de x_advect', tm*dx*dx*dx
+ print*, 'NPART, NTAG selon x ', npart,ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..d21567ae8967a81a1eab2d0f1aa9476608bb9025
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omy_l4.f
@@ -0,0 +1,118 @@
+ subroutine x_advect_omy(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ tm=0.
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ yy=xmin+float(j-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do i=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(ug(j1,j,k))+abs(ug(j2,j,k))+abs(ug(j3,j,k))
+ 1 +abs(ug(j4,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg2(j2,j,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg2(j3,j,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg2(j4,j,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg2(j1,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+ if (ntag+np_aux.ne.np) print*, ntag,np_aux,np
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx_omy(np_aux,xp_aux,up_aux,itype_aux,jr,kr)
+ if (ntag.ne.0) call remeshx_omy_tag(ntag,itag,itype,icfl,jr,kr)
+
+! fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG selon x ', npart,ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..3efc2214c7236aadd7262b3b46206b5a70ed8ef2
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_omz_l4.f
@@ -0,0 +1,117 @@
+ subroutine x_advect_omz(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ yy=xmin+float(j-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do i=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(omg3(j1,j,k))+abs(omg3(j2,j,k))+abs(omg3(j3,j,k))
+ 1 +abs(omg3(j4,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg3(j2,j,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg3(j3,j,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg3(j4,j,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg3(j1,j,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(j1,j,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+ if (ntag+np_aux.ne.np) print*, ntag,np_aux,np
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx_omz(np_aux,xp_aux,up_aux,itype_aux,jr,kr)
+ if (ntag.ne.0) call remeshx_omz_tag(ntag,itag,itype,icfl,jr,kr)
+
+! fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG selon x ', npart,ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_orig.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_orig.f
new file mode 100644
index 0000000000000000000000000000000000000000..14dc11331f3a733162d945d873b98b7bd99c312e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/x_advect_orig.f
@@ -0,0 +1,79 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+! initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np,xp_aux,up_aux,itype,jr,kr)
+
+! fin de ligne j,k:
+ npart=npart+np
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec.f
new file mode 100644
index 0000000000000000000000000000000000000000..3c7c0d7862dae6ee3698e24ae66a66d1ebc70f93
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec.f
@@ -0,0 +1,80 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+
+! cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+! on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+! initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np_aux,xp_aux,up_aux,itype_aux,ir,kr)
+ if (ntag.ne.0) call remeshy_tag(ntag,itag,itype,icfl,ir,kr)
+
+! fin de ligne i :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+ print*, ' NTAG apres y advect ', ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..4255e2096d5483aaee53964ad5b309e11514df58
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_corec_limit.f
@@ -0,0 +1,82 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+ dimension sl(npg),sl1(npg),sl2(npg)
+
+! cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+! on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+! initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+c pentes pour limiteurs
+
+ call slopes(dt,np,sl)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux,sl,sl1,sl2)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np_aux,xp_aux,up_aux,itype_aux,ir,kr,sl1,sl2)
+ if (ntag.ne.0) call remeshy_tag(ntag,itag,itype,icfl,ir,kr,sl)
+
+! fin de ligne i :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+ print*, ' NTAG apres y advect ', ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..511f416faae930ffb4324426544e05a53224ba67
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l2.f
@@ -0,0 +1,63 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+! initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np,xp_aux,up_aux,itype,ir,kr)
+! fin de ligne i :
+
+ endif
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..ae513525fcfd1a3925b39136c4ec3a9033284dd1
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_l4.f
@@ -0,0 +1,120 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ tm=0.
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+! on balaie le lignes verticales
+
+ print*,'circlim =',circlim
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do j=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(ug(i,j1,k))+abs(ug(i,j2,k))+abs(ug(i,j3,k))
+ 1 +abs(ug(i,j4,k)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(i,j1,k)
+ tm=tm+ug(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=ug(i,j2,k)
+ tm=tm+ug(i,j2,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=ug(i,j3,k)
+ tm=tm+ug(i,j3,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=ug(i,j4,k)
+ tm=tm+ug(i,j4,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(ug(i,j1,k)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(i,j1,k)
+ tm=tm+ug(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np_aux,xp_aux,up_aux,itype_aux,ir,kr)
+ if (ntag.ne.0)
+ 1 call remeshy_tag(ntag,itag,itype,icfl,ir,kr)
+
+! fin de ligne i :
+
+ endif
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ if (ntag_total.lt.0) print*, 'BIZZ ',ntag,i,k
+ enddo
+ enddo
+
+ print*, 'TM debut de y_advect', tm*dx*dx*dx
+ print*, ' NTAG apres y advect ', ntag_total
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..8af976af9d97190b22670ad916d993c3cc78d6e3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omy_l4.f
@@ -0,0 +1,113 @@
+ subroutine y_advect_omy(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+! on balaie le lignes verticales
+
+ print*,'circlim =',circlim
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do j=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(omg2(i,j1,k))+abs(omg2(i,j2,k))+abs(omg2(i,j3,k))
+ 1 +abs(omg2(i,j4,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg2(i,j2,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg2(i,j3,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg2(i,j4,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg2(i,j1,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy_omy(np_aux,xp_aux,up_aux,itype_aux,ir,kr)
+ if (ntag.ne.0)
+ 1 call remeshy_omy_tag(ntag,itag,itype,icfl,ir,kr)
+
+! fin de ligne i :
+
+ endif
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ if (ntag_total.lt.0) print*, 'BIZZ ',ntag,i,k
+ enddo
+ enddo
+
+ print*, ' NTAG apres y advect ', ntag_total
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..0ecd00a96b80022c10c7e73c94cd9c8dd0535a1e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_omz_l4.f
@@ -0,0 +1,113 @@
+ subroutine y_advect_omz(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+ m=np_bl+1
+
+! on balaie le lignes verticales
+
+ print*,'circlim =',circlim
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do j=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(omg3(i,j1,k))+abs(omg3(i,j2,k))+abs(omg3(i,j3,k))
+ 1 +abs(omg3(i,j4,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg3(i,j2,k)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg3(i,j3,k)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg3(i,j4,k)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg3(i,j1,k)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(i,j1,k)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy_omz(np_aux,xp_aux,up_aux,itype_aux,ir,kr)
+ if (ntag.ne.0)
+ 1 call remeshy_omz_tag(ntag,itag,itype,icfl,ir,kr)
+
+! fin de ligne i :
+
+ endif
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ if (ntag_total.lt.0) print*, 'BIZZ ',ntag,i,k
+ enddo
+ enddo
+
+ print*, ' NTAG apres y advect ', ntag_total
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_orig.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_orig.f
new file mode 100644
index 0000000000000000000000000000000000000000..511f416faae930ffb4324426544e05a53224ba67
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/y_advect_orig.f
@@ -0,0 +1,63 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+! initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np,xp_aux,up_aux,itype,ir,kr)
+! fin de ligne i :
+
+ endif
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec.f
new file mode 100644
index 0000000000000000000000000000000000000000..38620f9a2e1ff5eae884409aa512650c7053534f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec.f
@@ -0,0 +1,79 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! cf=dt/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+! initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np_aux,xp_aux,up_aux,itype_aux,ir,jr)
+ if (ntag.ne.0) call remeshz_tag(ntag,itag,itype,icfl,ir,jr)
+
+! fin de ligne k :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec_limit.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec_limit.f
new file mode 100644
index 0000000000000000000000000000000000000000..6462563262dfd92295a921dd710d45a0af0dfc9a
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_corec_limit.f
@@ -0,0 +1,84 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+ dimension sl(npg),sl1(npg),sl2(npg)
+
+! cf=dt/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+! initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+c pentes pour limiteurs
+
+ call slopes(dt,np,sl)
+
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux,sl,sl1,sl2)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np_aux,xp_aux,up_aux,itype_aux,ir,jr,sl1,sl2)
+ if (ntag.ne.0) call remeshz_tag(ntag,itag,itype,icfl,ir,jr,sl)
+
+! fin de ligne k :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l2.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..52daac924f24d8297aa662eb74840837586adb51
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l2.f
@@ -0,0 +1,63 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+! initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np,xp_aux,up_aux,itype,ir,jr)
+! fin de ligne k :
+ endif
+ enddo
+ enddo
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..610b937f4127df15ce581886adfc7aa7418bc286
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_l4.f
@@ -0,0 +1,113 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cf=ldx/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ tm=0.
+ m=np_bl+1
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do k=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(ug(i,j,j1))+abs(ug(i,j,j2))+abs(ug(i,j,j3))
+ 1 +abs(ug(i,j,j4)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(i,j,j1)
+ tm=tm+ug(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=ug(i,j,j2)
+ tm=tm+ug(i,j,j2)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=ug(i,j,j3)
+ tm=tm+ug(i,j,j3)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=ug(i,j,j4)
+ tm=tm+ug(i,j,j4)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(ug(i,j,j1)).ge.circlim)) then
+ np=np+1
+ up(np)=ug(i,j,j1)
+ tm=tm+ug(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np_aux,xp_aux,up_aux,itype_aux,ir,jr)
+ if (ntag.ne.0) call remeshz_tag(ntag,itag,itype,icfl,ir,jr)
+
+! fin de ligne k :
+
+ endif
+ enddo
+ enddo
+
+ print*, 'TM debut de z_advect', tm*dx*dx*dx
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omy_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omy_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..f424ef285df07a9d6cba36a8ff316fb9cf723041
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omy_l4.f
@@ -0,0 +1,106 @@
+ subroutine z_advect_omy(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cf=ldx/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ m=np_bl+1
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do k=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(omg2(i,j,j1))+abs(omg2(i,j,j2))+abs(omg2(i,j,j3))
+ 1 +abs(omg2(i,j,j4)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg2(i,j,j2)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg2(i,j,j3)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg2(i,j,j4)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg2(i,j,j1)).ge.circlim)) then
+ np=np+1
+ up(np)=omg2(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz_omy(np_aux,xp_aux,up_aux,itype_aux,ir,jr)
+ if (ntag.ne.0) call remeshz_omy_tag(ntag,itag,itype,icfl,ir,jr)
+
+! fin de ligne k :
+
+ endif
+ enddo
+ enddo
+
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omz_l4.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omz_l4.f
new file mode 100644
index 0000000000000000000000000000000000000000..9b403d8f70eea9dc81e7731946f45fc51ec34833
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_omz_l4.f
@@ -0,0 +1,106 @@
+ subroutine z_advect_omz(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+! cf=ldx/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ m=np_bl+1
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ yy=xmin+float(i-1)*dx
+ np=0
+ jj=3
+ ic=0
+ do k=3,nx+2
+ jj=jj+ic
+ if (jj.gt.nx+2) go to 111
+ j1=mod(jj-1,nx)+1
+ j2=mod(jj,nx)+1
+ j3=mod(jj+1,nx)+1
+ j4=mod(jj+2,nx)+1
+ if ((mod(j1,m).eq.m-1).and.
+ 1 (abs(omg3(i,j,j1))+abs(omg3(i,j,j2))+abs(omg3(i,j,j3))
+ 1 +abs(omg3(i,j,j4)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ np=np+1
+ up(np)=omg3(i,j,j2)
+ xp(np)=xmin+float(j2-1)*dx
+ np=np+1
+ up(np)=omg3(i,j,j3)
+ xp(np)=xmin+float(j3-1)*dx
+ np=np+1
+ up(np)=omg3(i,j,j4)
+ xp(np)=xmin+float(j4-1)*dx
+ ic=4
+ elseif ((abs(omg3(i,j,j1)).ge.circlim)) then
+ np=np+1
+ up(np)=omg3(i,j,j1)
+ xp(np)=xmin+float(j1-1)*dx
+ ic=1
+ else
+ ic=1
+ endif
+ enddo
+111 continue
+
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz_omz(np_aux,xp_aux,up_aux,itype_aux,ir,jr)
+ if (ntag.ne.0) call remeshz_omz_tag(ntag,itag,itype,icfl,ir,jr)
+
+! fin de ligne k :
+
+ endif
+ enddo
+ enddo
+
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_orig.f b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_orig.f
new file mode 100644
index 0000000000000000000000000000000000000000..52daac924f24d8297aa662eb74840837586adb51
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/NotUsed/z_advect_orig.f
@@ -0,0 +1,63 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+! initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np,xp_aux,up_aux,itype,ir,jr)
+! fin de ligne k :
+ endif
+ enddo
+ enddo
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/README b/CodesEnVrac/CodeGH/src-THI/README
new file mode 100644
index 0000000000000000000000000000000000000000..2f8f0cc5ea59bc1fbcdadc0937fad38af7517724
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/README
@@ -0,0 +1,54 @@
+9/07/2010
+
+recopie en partie CEA/OM/JET/BILEVEL
+pour tester remaillage de scalaire avec corrections
+(routines de Remesh_test/3Dlin_new)
+
+*_full routniens completes (NX + scalaire)
+*_small routines avec suelement transport scalaire par champ de vitess de la sphere cisaillee
+
+3/09/2010
+filter_rho: routne qui ne calcule le spectre de rho que pour les premiers modes et
+qui retroune un rho filtre (pour ne pas avoir a trimblaer des fichiers trop lourds a visualiser)
+
+Janvier 2011:
+
+mis un pue d'oordre pour tester les spectres de rho avec les differents reamillage
+
+main_small_split: juste advectnio d'un scalaire avec un champ de vitesse fixe
+lu dans initread.f ; champ turublent 128^3, fourni par GB, obtenu par filtre 32^2, padde avec des 0 jusqu'a 128 (data2write)
+remaillage splitte lambda 2, + RK 2
+*_advec_orig ou __advec_corec: routnes d'advection avec remaillages 1D d'origine ou corriges
+
+main_small_nosplit: idem mais avec remaillage tensoriel m'4
+o
+1 ite en temps: les fomules non-corrigees plittees donnes une remontee du bout de spectre
+pour cfl > 0.5
+formules corrigees eliminent le probleme (juste legere inflexion du spctre autour de 20
+
+formules M'4 tensorielle adonne des bumps successifs sur spectre. (qulque soit cfl car itype =0 dans l'implementation de m'4)
+
+ecrit remesh*_m4 (avec itype =0 : formules a gauche)
+cree remeshx,y,z et mis dans le makefile (pour pouvoir changer les
+formules de reamillage 1D)
+
+cree *_limit.f a partir des formules avec limteurs testes et valides dans
+directory Limt
+
+15/02/11
+tentative de fiare burgers 1d avec transport par champe filtre (avec fft3D ..)
+-> routnes *_burgers*, makefile_burgers ..
+pas concluat (les pentes en 1/epsilon créées des overshoots ce qui est normal a poteiroiri (quel que soit le pas de temps, meme avec remesh M3)
+
+
+20/06/11
+commence a faire du denste varaible.
+remesh lmabda4 corrigees
+makfeil_freeb
+1) Boussinesq sans tension superificielle
+makefile_freeb
+-> routne init_freeb (avec scalaire = densite dans une sphere)
+main_freeb ou on ajoute
+2) tension superificielle ajoutee : stension.f
+teste, ok qualitativement avec lcfl O.5 nu=0.0005 et Pr=0.0001, nx=256 filtre a 64, tau=0.01
+ex= rho_256x64_tau=0.01_t=05.gz, 0.55 et 0.8
diff --git a/CodesEnVrac/CodeGH/src-THI/arrays.h b/CodesEnVrac/CodeGH/src-THI/arrays.h
new file mode 100644
index 0000000000000000000000000000000000000000..e45762cf0e9a9d94b3fd507687b098eda0fe3c05
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/arrays.h
@@ -0,0 +1,10 @@
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),vx(npg)
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/diag.f b/CodesEnVrac/CodeGH/src-THI/diag.f
new file mode 100644
index 0000000000000000000000000000000000000000..d1fc519cb91c11078e575370ad170e7cd47b49dd
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/diag.f
@@ -0,0 +1,92 @@
+ subroutine diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+
+! calcul sur une grille mxmxm de (a,b)**3 du
+! div w, enstro et energy
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension umean(npgy)
+
+
+
+ eps3=dx1**3
+ vol=eps3
+
+ dxinv2=0.5/dx1
+ dyinv2=0.5/dx1
+ dzinv2=0.5/dx1
+
+ omax=0.
+ rhomax=0.
+ div=0.
+ domax=0.
+ ener=0.
+ enstro=0.
+ dudymax=0.
+ do 10 k=1,nz1
+ kt=mod(k,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ do 10 j=1,ny1
+ jt=mod(j,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ do 10 i=1,nx1
+ it=mod(i,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ aux1=omg1(it,j,k)-omg1(ib,j,k)
+ aux2=omg2(i,jt,k)-omg2(i,jb,k)
+ aux3=(omg3(i,j,kt)-omg3(i,j,kb))
+ psi1(i,j,k)=(aux1*dxinv2+aux2*dyinv2+aux3*dzinv2)
+ div=div+((aux1*dxinv2+aux2*dyinv2+aux3*dzinv2)**2)*eps3
+ domax=domax+((abs(aux1*dxinv2)+abs(aux2*dyinv2)+
+ 1 abs(aux3*dzinv2))**2)*eps3
+ enerx=vxg(i,j,k)*vxg(i,j,k)
+ enery=vyg(i,j,k)*vyg(i,j,k)
+ enerz=vzg(i,j,k)*vzg(i,j,k)
+ strengthx=omg1(i,j,k)*omg1(i,j,k)
+ strengthy=omg2(i,j,k)*omg2(i,j,k)
+ strengthz=omg3(i,j,k)*omg3(i,j,k)
+ omax=amax1(omax,sqrt(strengthx+strengthy+strengthz))
+ rhomax=amax1(rhomax,ug(i,j,k))
+ enstro=enstro+(strengthx+strengthy+strengthz)*vol
+ ener=ener+(enerx+enery+enerz)*vol
+10 continue
+
+! goto 111
+
+ do j=1,ny1
+ umean(j)=0.
+ do i=1,nx1
+ do k=1,nz1
+ umean(j)=umean(j)+dx1*dx1*vxg(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ dudymax=0.
+ do j=2,ny1-1
+ dudymax=amax1(dudymax,umean(j+1)-umean(j-1))
+ enddo
+
+ width=0.
+ if (dudymax.ne.0.) width=2.*dx1/dudymax
+ if (domax.ne.0) div=div/domax
+
+111 continue
+
+
+ VOL1=0.
+ VOL2=0.
+ VOL3=0.
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).ge.0.5) VOL1=VOL1+dx2*dx2*dx2
+ if (ug(i,j,k).ge.0.75) VOL2=VOL2+dx2*dx2*dx2
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/dif.f b/CodesEnVrac/CodeGH/src-THI/dif.f
new file mode 100644
index 0000000000000000000000000000000000000000..ab491a109419215817d5160588c8f91be9cc8e3e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/dif.f
@@ -0,0 +1,154 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE dif_om(npart,om1,om2,om3,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax1)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ dxinv=1./(dx1)
+ dy1=dx1
+ dz1=dx1
+ dyinv=dxinv
+ dzinv=dxinv
+
+ npart=0
+ vol=dx1**3
+
+ do k=1,nz1
+ z=zmin+(k-1)*dz1
+ do j=1,ny1
+ y=ymin+(j-1)*dy1
+ do i=1,nx1
+ x=xmin+(i-1)*dx1
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx1**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ enddo
+ enddo
+ enddo
+
+! goto 1001
+
+ dzdx=(dz1/dx1)**2
+ dzdy=(dz1/dy1)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+c boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+c boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx1-1,nx1)+1
+ j2=mod(jj+ly+ny1-1,ny1)+1
+ k2=mod(kk+lz+nz1-1,nz1)+1
+ gammasrc1=omg1(i2,j2,k2)*vol
+ gammasrc2=omg2(i2,j2,k2)*vol
+ gammasrc3=omg3(i2,j2,k2)*vol
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ dvx=(vxsrc-vxrcv)/dx1
+ dvy=(vysrc-vyrcv)/dy1
+ dvz=(vzsrc-vzrcv)/dz1
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ ales=amax1(0.,-dvx*lx-dvy*ly-dvz*lz)
+c ales=abs(dvx*lx+dvy*ly+dvz*lz)
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ akernel2=2.5/((1.+r)*2.8333)
+ factor=akernel/(dz1*dz1)
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy1*dx1*dz1/dv1(i))
+
+c enddo pour caluc de dom sur les particules
+ enddo
+
+1001 continue
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv1(i))
+ omax0=amax1(omax0,abs(om2(i))/dv1(i))
+ omax0=amax1(omax0,abs(om3(i))/dv1(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv1(i))
+ omax1=amax1(omax1,abs(om2(i))/dv1(i))
+ omax1=amax1(omax1,abs(om3(i))/dv1(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/dif_rho.f b/CodesEnVrac/CodeGH/src-THI/dif_rho.f
new file mode 100644
index 0000000000000000000000000000000000000000..405711fb736a3e62629f4b6dc7ffe7c75d24a79c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/dif_rho.f
@@ -0,0 +1,40 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE dif_rho(anu,dt)
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ anudt=anu*dt/(dx2**2)
+
+ rhomax1=0.
+ rhomax2=0.
+
+ do k=1,nz2
+ kt=mod(k,nz2)+1
+ kb=mod(k-2+nz2,nz2)+1
+ do j=1,ny2
+ jt=mod(j,nz2)+1
+ jb=mod(j-2+nz2,nz2)+1
+ do i=1,nx2
+ it=mod(i,nz2)+1
+ ib=mod(i-2+nz2,nz2)+1
+ drho=ug(it,j,k)+ug(ib,j,k)+ug(i,jt,k)+ug(i,jb,k)+ug(i,j,kt)+ug(i,j,kb)
+ drho=drho-6.*ug(i,j,k)
+ rhomax1=amax1(rhomax1,abs(ug(i,j,k)))
+ ug(i,j,k)=ug(i,j,k)+anudt*drho
+ rhomax2=amax1(rhomax2,abs(ug(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'RHOMAX avant et apres DIFF ',rhomax1,rhomax2
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/fftw_f77.i b/CodesEnVrac/CodeGH/src-THI/fftw_f77.i
new file mode 100644
index 0000000000000000000000000000000000000000..26c3524023481eeaead10895b12c4bd72e700ea4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/fftw_f77.i
@@ -0,0 +1,17 @@
+c This file contains PARAMETER statements for various constants
+c that can be passed to FFTW routines. You should include
+c this file in any FORTRAN program that calls the fftw_f77
+c routines (either directly or with an #include statement
+c if you use the C preprocessor).
+
+ INTEGER FFTW_FORWARD,FFTW_BACKWARD
+ PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+
+ INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+ PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+
+ INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+ PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+
+ INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+ PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
diff --git a/CodesEnVrac/CodeGH/src-THI/fortranize.h b/CodesEnVrac/CodeGH/src-THI/fortranize.h
new file mode 100644
index 0000000000000000000000000000000000000000..fb4a6b8b6dac73c64abd27aa3013338ea6be7ebb
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/fortranize.h
@@ -0,0 +1,50 @@
+/*
+ * Copyright (c) 1997,1998 Massachusetts Institute of Technology
+ *
+ * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *
+ */
+
+#ifndef FORTRANIZE_H
+#define FORTRANIZE_H
+
+/*
+ * convert C name -> FORTRAN name. On some systems,
+ * append an underscore. On other systems, use all caps.
+ *
+ * x is the lower case name, X is the all caps name.
+ */
+
+#if defined(CRAY) || defined(_UNICOS) || defined(_CRAYMPP)
+#define FORTRANIZE(x,X) X /* all upper-case on the Cray */
+
+#elif defined(IBM6000) || defined(_AIX)
+#define FORTRANIZE(x,X) x /* all lower-case on RS/6000 */
+
+#elif defined(__hpux)
+#define FORTRANIZE(x,X) x /* all lower-case on HP-UX */
+
+#elif defined(USING_G77) /* users should define this when using with the g77
+ Fortran compiler */
+#define FORTRANIZE(x,X) x##__ /* g77 expects *two* underscores after
+ names with an underscore */
+
+#else
+#define FORTRANIZE(x,X) x##_ /* use all lower-case with underscore
+ by default */
+
+#endif
+
+#endif /* FORTRANIZE_H */
diff --git a/CodesEnVrac/CodeGH/src-THI/initjet.f b/CodesEnVrac/CodeGH/src-THI/initjet.f
new file mode 100644
index 0000000000000000000000000000000000000000..7b136b188d6c395fccdae0ac1d986562ae0dbcfa
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/initjet.f
@@ -0,0 +1,143 @@
+ subroutine jet(npart,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension omx(*),omy(*),omz(*)
+
+ pi=3.1415926
+ pi2=2.*pi
+ circ=0.
+ x0=0.
+ y0=0.
+ z0=0.
+! momentum thickness
+ width=0.01
+! noise level for the flow
+ ampl=0.05
+! ampl=0.0
+! apltude of wave for vx
+ ampl3=0.3
+! noise level for the scalar
+ ampl2=0.05
+ ampl2=0.
+
+ open(20,file='random',form='unformatted',
+ 1 status='unknown')
+
+ read(20) (((strg1(i,j,k),strg2(i,j,k),strg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+
+
+ do i=1,nx1
+ do j=1,ny1
+ do k=1,nz1
+ yy=abs(float(j-1)*dx1-0.5)
+ aux=(0.1-2.*yy)/(4.*width)
+ aux4=abs(aux**2)
+ strg1(i,j,k)=exp(-aux4)*(strg1(i,j,k)-0.5)
+ strg2(i,j,k)=exp(-aux4)*(strg2(i,j,k)-0.5)
+ strg3(i,j,k)=exp(-aux4)*(strg3(i,j,k)-0.5)
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+ ug(i,j,k)=0.
+ enddo
+ enddo
+ enddo
+
+ vxmax=0.
+
+ do i=1,nx1
+ xx=float(i-1)*dx1
+ do k=1,nz1
+ zz=float(k-1)*dx1
+ do j=1,ny1
+ yy=abs(float(j-1)*dx1-0.5)
+ aux=(0.1-2.*yy)/(4.*width)
+c vxg(i,j,k)=0.5*(1.+tanh(aux))*(1.+ampl*strg1(i,j,k))
+ vxg(i,j,k)=0.5*(1.+tanh(aux))*(1.+ampl3*sin(4*pi2*(xx)))
+ vxg(i,j,k)=vxg(i,j,k)*(1.+ampl*strg1(i,j,k))
+ vyg(i,j,k)=ampl*strg2(i,j,k)
+ vzg(i,j,k)=ampl*strg3(i,j,k)
+ vxmax=amax1(vxmax,abs(vxg(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'VXMAX =', VXMAX
+
+ dxinv=0.5/dx1
+ npart=0
+ do 10 i=1,nx1
+ it=mod(i+nx1,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ xx=(float(i)-1.)*dx1
+ do 10 j=1,ny1
+ jt=mod(j+ny1,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ yy=(float(j)-1.)*dx1
+ do 10 k=1,nz1
+ kt=mod(k+nz1,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ zz=(float(k)-1.)*dx1
+ dwdx=vzg(it,j,k)-vzg(ib,j,k)
+ dwdy=vzg(i,jt,k)-vzg(i,jb,k)
+ dudy=vxg(i,jt,k)-vxg(i,jb,k)
+ dudz=vxg(i,j,kt)-vxg(i,j,kb)
+ dvdx=vyg(it,j,k)-vyg(ib,j,k)
+ dvdz=vyg(i,j,kt)-vyg(i,j,kb)
+ aux3=(dvdx-dudy)*dxinv
+ aux1=(dwdy-dvdz)*dxinv
+ aux2=(dudz-dwdx)*dxinv
+ccc
+! aux1=0.
+! aux2=0.
+ omg1(i,j,k)=aux1
+ omg2(i,j,k)=aux2
+ omg3(i,j,k)=aux3
+ if (abs(aux1)+abs(aux2)+abs(aux3).gt.0.0001) then
+ npart=npart+1
+ xp1(npart)=xx
+ yp1(npart)=yy
+ zp1(npart)=zz
+ dv1(npart)=dx1*dx1*dx1
+ omx(npart)=dv1(npart)*aux1
+ omy(npart)=dv1(npart)*aux2
+ omz(npart)=dv1(npart)*aux3
+ circ=circ+omz(npart)
+ endif
+10 continue
+ print*, 'NPART =', npart
+ do i=1,npart
+! omz(npart)=omz(npart)-circ/float(npart)
+ enddo
+
+ tm=0.
+ do k=1,nz2
+ do j=1,ny2
+ yy=abs(float(j-1)*dx2-0.5)
+ aux=(0.1-2.*yy)/(4.*width)
+ aux2=aux**2
+ do i=1,nx2
+ ug(i,j,k)=0.
+c ug(i,j,k)=1.
+ val=0.5*(1.+tanh(aux))*(1.+ampl2*strg3(i,j,k))
+ if (val.gt.0.0001) then
+ npart_rho=npart_rho+1
+ ug(i,j,k)=val
+ tm=tm+val
+c ug(i,j,k)=1.
+ endif
+ enddo
+ enddo
+ enddo
+
+ print*, ' MASSE SCALAIRE a init ',tm*dx2*dx2*dx2
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/initread.f b/CodesEnVrac/CodeGH/src-THI/initread.f
new file mode 100644
index 0000000000000000000000000000000000000000..63dbae8d40306365a3dd1288108595e793364c4f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/initread.f
@@ -0,0 +1,81 @@
+ subroutine readfield(rhomax,vmax,dvmax)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ real*8 tout(npgx,npgy,npgz,4)
+
+ rhomax=0.
+
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ ug(i,j,k)=1.
+ rhomax=amax1(umax,abs(ug(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+! goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi1(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi2(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ open(20,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+ read(20) (((psi3(i,j,k),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+
+ close(20)
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+ vmax=amax1(umax1,umax2,umax3)
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvmax=amax1(dvmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvmax=amax1(dvmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+111 continue
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/interho.f b/CodesEnVrac/CodeGH/src-THI/interho.f
new file mode 100644
index 0000000000000000000000000000000000000000..f422a1ff0a21b234b1177cbb684a7c4934a868ef
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/interho.f
@@ -0,0 +1,149 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE interho(npart,g1,g2,g3,xp,yp,zp)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+
+ do 10 i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+ dyinv=1./dy3
+ dzinv=1./dz3
+ dh3=dx3*dy3*dz3
+ dhinv3=1./dh3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ yy1 = (y - float(jp1)*dy3-y0)*dyinv
+ zz1 = (z - float(kp1)*dz3-z0)*dzinv
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+
+
+ jp1=mod(jp1+ny3,ny3) +1
+ jp2=mod(jp2+ny3,ny3) +1
+
+ kp1=mod(kp1+nz3,nz3) +1
+ kp2=mod(kp2+nz3,nz3) +1
+
+C
+C The M'4 scheme
+C
+
+ a1 = xx2
+ b1 = yy2
+ c1 = zz2
+
+ a2 = xx1
+ b2 = yy1
+ c2 = zz1
+
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+
+ g2(i)= g2(i) + gg2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + gg2(ip1,jp2,kp1)*a1*b2*c1
+
+ g3(i)= g3(i) + gg3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + gg3(ip1,jp2,kp1)*a1*b2*c1
+c
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+
+ g2(i)= g2(i) + gg2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + gg2(ip2,jp2,kp1)*a2*b2*c1
+
+ g3(i)= g3(i) + gg3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + gg3(ip2,jp2,kp1)*a2*b2*c1
+c
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+
+ g2(i)= g2(i) + gg2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + gg2(ip1,jp2,kp2)*a1*b2*c2
+
+ g3(i)= g3(i) + gg3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + gg3(ip1,jp2,kp2)*a1*b2*c2
+c
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+ g2(i)= g2(i) + gg2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + gg2(ip2,jp2,kp2)*a2*b2*c2
+
+ g3(i)= g3(i) + gg3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + gg3(ip2,jp2,kp2)*a2*b2*c2
+c
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/intersm4.f90 b/CodesEnVrac/CodeGH/src-THI/intersm4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c8f17e55a58c94548b209fba842f55d3ace0395b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/intersm4.f90
@@ -0,0 +1,372 @@
+!
+ SUBROUTINE intersm4(npart,g1,g2,g3,xp,yp,zp)
+
+!
+! Interpolation routine with M'4
+!
+! geometry=unit box, periodic in x and y
+! last ponits in z direction assume extension by continuity
+! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+ include 'param.i'
+ include 'param.h'
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & ug(npg,npg,npg)
+
+
+ dy1=dx1
+ dz1=dx1
+
+ do 10 i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+10 continue
+
+ dxinv=1./dx1
+ dyinv=1./dy1
+ dzinv=1./dz1
+ dh3=dx1*dy1*dz1
+ dhinv3=1./dh3
+
+
+!--------------------------------------------------------------------
+!- PART II : Determination of the circulation of each particle
+!--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+
+! get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx1-x0)*dxinv
+ yy1 = (y - float(jp1)*dy1-y0)*dyinv
+ zz1 = (z - float(kp1)*dz1-z0)*dzinv
+ xx0=xx1+1
+ yy0=yy1+1
+ zz0=zz1+1
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+ xx3=2-xx1
+ yy3=2-yy1
+ zz3=2-zz1
+
+
+!
+! on repositionne les points de grille par periodicite
+! entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx1,nx1) +1
+ ip0=mod(ip0+nx1,nx1) +1
+ ip2=mod(ip2+nx1,nx1) +1
+ ip3=mod(ip3+nx1,nx1) +1
+
+! print*,ip0,ip1,ip2,ip3
+
+ jp1=mod(jp1+ny1,ny1) +1
+ jp0=mod(jp0+ny1,ny1) +1
+ jp2=mod(jp2+ny1,ny1) +1
+ jp3=mod(jp3+ny1,ny1) +1
+
+ kp1=mod(kp1+nz1,nz1) +1
+ kp0=mod(kp0+nz1,nz1) +1
+ kp2=mod(kp2+nz1,nz1) +1
+ kp3=mod(kp3+nz1,nz1) +1
+C
+! The M'4 scheme
+!
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp0)*a0*b0*c0
+ g1(i)= g1(i) + GG1(ip0,jp1,kp0)*a0*b1*c0
+ g1(i)= g1(i) + GG1(ip0,jp2,kp0)*a0*b2*c0
+ g1(i)= g1(i) + GG1(ip0,jp3,kp0)*a0*b3*c0
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp0)*a0*b0*c0
+ g2(i)= g2(i) + GG2(ip0,jp1,kp0)*a0*b1*c0
+ g2(i)= g2(i) + GG2(ip0,jp2,kp0)*a0*b2*c0
+ g2(i)= g2(i) + GG2(ip0,jp3,kp0)*a0*b3*c0
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp0)*a0*b0*c0
+ g3(i)= g3(i) + GG3(ip0,jp1,kp0)*a0*b1*c0
+ g3(i)= g3(i) + GG3(ip0,jp2,kp0)*a0*b2*c0
+ g3(i)= g3(i) + GG3(ip0,jp3,kp0)*a0*b3*c0
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp0)*a1*b0*c0
+ g1(i)= g1(i) + GG1(ip1,jp1,kp0)*a1*b1*c0
+ g1(i)= g1(i) + GG1(ip1,jp2,kp0)*a1*b2*c0
+ g1(i)= g1(i) + GG1(ip1,jp3,kp0)*a1*b3*c0
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp0)*a1*b0*c0
+ g2(i)= g2(i) + GG2(ip1,jp1,kp0)*a1*b1*c0
+ g2(i)= g2(i) + GG2(ip1,jp2,kp0)*a1*b2*c0
+ g2(i)= g2(i) + GG2(ip1,jp3,kp0)*a1*b3*c0
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp0)*a1*b0*c0
+ g3(i)= g3(i) + GG3(ip1,jp1,kp0)*a1*b1*c0
+ g3(i)= g3(i) + GG3(ip1,jp2,kp0)*a1*b2*c0
+ g3(i)= g3(i) + GG3(ip1,jp3,kp0)*a1*b3*c0
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp0)*a2*b0*c0
+ g1(i)= g1(i) + GG1(ip2,jp1,kp0)*a2*b1*c0
+ g1(i)= g1(i) + GG1(ip2,jp2,kp0)*a2*b2*c0
+ g1(i)= g1(i) + GG1(ip2,jp3,kp0)*a2*b3*c0
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp0)*a2*b0*c0
+ g2(i)= g2(i) + GG2(ip2,jp1,kp0)*a2*b1*c0
+ g2(i)= g2(i) + GG2(ip2,jp2,kp0)*a2*b2*c0
+ g2(i)= g2(i) + GG2(ip2,jp3,kp0)*a2*b3*c0
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp0)*a2*b0*c0
+ g3(i)= g3(i) + GG3(ip2,jp1,kp0)*a2*b1*c0
+ g3(i)= g3(i) + GG3(ip2,jp2,kp0)*a2*b2*c0
+ g3(i)= g3(i) + GG3(ip2,jp3,kp0)*a2*b3*c0
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp0)*a3*b0*c0
+ g1(i)= g1(i) + GG1(ip3,jp1,kp0)*a3*b1*c0
+ g1(i)= g1(i) + GG1(ip3,jp2,kp0)*a3*b2*c0
+ g1(i)= g1(i) + GG1(ip3,jp3,kp0)*a3*b3*c0
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp0)*a3*b0*c0
+ g2(i)= g2(i) + GG2(ip3,jp1,kp0)*a3*b1*c0
+ g2(i)= g2(i) + GG2(ip3,jp2,kp0)*a3*b2*c0
+ g2(i)= g2(i) + GG2(ip3,jp3,kp0)*a3*b3*c0
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp0)*a3*b0*c0
+ g3(i)= g3(i) + GG3(ip3,jp1,kp0)*a3*b1*c0
+ g3(i)= g3(i) + GG3(ip3,jp2,kp0)*a3*b2*c0
+ g3(i)= g3(i) + GG3(ip3,jp3,kp0)*a3*b3*c0
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp1)*a0*b0*c1
+ g1(i)= g1(i) + GG1(ip0,jp1,kp1)*a0*b1*c1
+ g1(i)= g1(i) + GG1(ip0,jp2,kp1)*a0*b2*c1
+ g1(i)= g1(i) + GG1(ip0,jp3,kp1)*a0*b3*c1
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp1)*a0*b0*c1
+ g2(i)= g2(i) + GG2(ip0,jp1,kp1)*a0*b1*c1
+ g2(i)= g2(i) + GG2(ip0,jp2,kp1)*a0*b2*c1
+ g2(i)= g2(i) + GG2(ip0,jp3,kp1)*a0*b3*c1
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp1)*a0*b0*c1
+ g3(i)= g3(i) + GG3(ip0,jp1,kp1)*a0*b1*c1
+ g3(i)= g3(i) + GG3(ip0,jp2,kp1)*a0*b2*c1
+ g3(i)= g3(i) + GG3(ip0,jp3,kp1)*a0*b3*c1
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp1)*a1*b0*c1
+ g1(i)= g1(i) + GG1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + GG1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + GG1(ip1,jp3,kp1)*a1*b3*c1
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp1)*a1*b0*c1
+ g2(i)= g2(i) + GG2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + GG2(ip1,jp2,kp1)*a1*b2*c1
+ g2(i)= g2(i) + GG2(ip1,jp3,kp1)*a1*b3*c1
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp1)*a1*b0*c1
+ g3(i)= g3(i) + GG3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + GG3(ip1,jp2,kp1)*a1*b2*c1
+ g3(i)= g3(i) + GG3(ip1,jp3,kp1)*a1*b3*c1
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp1)*a2*b0*c1
+ g1(i)= g1(i) + GG1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + GG1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + GG1(ip2,jp3,kp1)*a2*b3*c1
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp1)*a2*b0*c1
+ g2(i)= g2(i) + GG2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + GG2(ip2,jp2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + GG2(ip2,jp3,kp1)*a2*b3*c1
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp1)*a2*b0*c1
+ g3(i)= g3(i) + GG3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + GG3(ip2,jp2,kp1)*a2*b2*c1
+ g3(i)= g3(i) + GG3(ip2,jp3,kp1)*a2*b3*c1
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp1)*a3*b0*c1
+ g1(i)= g1(i) + GG1(ip3,jp1,kp1)*a3*b1*c1
+ g1(i)= g1(i) + GG1(ip3,jp2,kp1)*a3*b2*c1
+ g1(i)= g1(i) + GG1(ip3,jp3,kp1)*a3*b3*c1
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp1)*a3*b0*c1
+ g2(i)= g2(i) + GG2(ip3,jp1,kp1)*a3*b1*c1
+ g2(i)= g2(i) + GG2(ip3,jp2,kp1)*a3*b2*c1
+ g2(i)= g2(i) + GG2(ip3,jp3,kp1)*a3*b3*c1
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp1)*a3*b0*c1
+ g3(i)= g3(i) + GG3(ip3,jp1,kp1)*a3*b1*c1
+ g3(i)= g3(i) + GG3(ip3,jp2,kp1)*a3*b2*c1
+ g3(i)= g3(i) + GG3(ip3,jp3,kp1)*a3*b3*c1
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp2)*a0*b0*c2
+ g1(i)= g1(i) + GG1(ip0,jp1,kp2)*a0*b1*c2
+ g1(i)= g1(i) + GG1(ip0,jp2,kp2)*a0*b2*c2
+ g1(i)= g1(i) + GG1(ip0,jp3,kp2)*a0*b3*c2
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp2)*a0*b0*c2
+ g2(i)= g2(i) + GG2(ip0,jp1,kp2)*a0*b1*c2
+ g2(i)= g2(i) + GG2(ip0,jp2,kp2)*a0*b2*c2
+ g2(i)= g2(i) + GG2(ip0,jp3,kp2)*a0*b3*c2
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp2)*a0*b0*c2
+ g3(i)= g3(i) + GG3(ip0,jp1,kp2)*a0*b1*c2
+ g3(i)= g3(i) + GG3(ip0,jp2,kp2)*a0*b2*c2
+ g3(i)= g3(i) + GG3(ip0,jp3,kp2)*a0*b3*c2
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp2)*a1*b0*c2
+ g1(i)= g1(i) + GG1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + GG1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + GG1(ip1,jp3,kp2)*a1*b3*c2
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp2)*a1*b0*c2
+ g2(i)= g2(i) + GG2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + GG2(ip1,jp2,kp2)*a1*b2*c2
+ g2(i)= g2(i) + GG2(ip1,jp3,kp2)*a1*b3*c2
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp2)*a1*b0*c2
+ g3(i)= g3(i) + GG3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + GG3(ip1,jp2,kp2)*a1*b2*c2
+ g3(i)= g3(i) + GG3(ip1,jp3,kp2)*a1*b3*c2
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp2)*a2*b0*c2
+ g1(i)= g1(i) + GG1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + GG1(ip2,jp2,kp2)*a2*b2*c2
+ g1(i)= g1(i) + GG1(ip2,jp3,kp2)*a2*b3*c2
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp2)*a2*b0*c2
+ g2(i)= g2(i) + GG2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + GG2(ip2,jp2,kp2)*a2*b2*c2
+ g2(i)= g2(i) + GG2(ip2,jp3,kp2)*a2*b3*c2
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp2)*a2*b0*c2
+ g3(i)= g3(i) + GG3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + GG3(ip2,jp2,kp2)*a2*b2*c2
+ g3(i)= g3(i) + GG3(ip2,jp3,kp2)*a2*b3*c2
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp2)*a3*b0*c2
+ g1(i)= g1(i) + GG1(ip3,jp1,kp2)*a3*b1*c2
+ g1(i)= g1(i) + GG1(ip3,jp2,kp2)*a3*b2*c2
+ g1(i)= g1(i) + GG1(ip3,jp3,kp2)*a3*b3*c2
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp2)*a3*b0*c2
+ g2(i)= g2(i) + GG2(ip3,jp1,kp2)*a3*b1*c2
+ g2(i)= g2(i) + GG2(ip3,jp2,kp2)*a3*b2*c2
+ g2(i)= g2(i) + GG2(ip3,jp3,kp2)*a3*b3*c2
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp2)*a3*b0*c2
+ g3(i)= g3(i) + GG3(ip3,jp1,kp2)*a3*b1*c2
+ g3(i)= g3(i) + GG3(ip3,jp2,kp2)*a3*b2*c2
+ g3(i)= g3(i) + GG3(ip3,jp3,kp2)*a3*b3*c2
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp3)*a0*b0*c3
+ g1(i)= g1(i) + GG1(ip0,jp1,kp3)*a0*b1*c3
+ g1(i)= g1(i) + GG1(ip0,jp2,kp3)*a0*b2*c3
+ g1(i)= g1(i) + GG1(ip0,jp3,kp3)*a0*b3*c3
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp3)*a0*b0*c3
+ g2(i)= g2(i) + GG2(ip0,jp1,kp3)*a0*b1*c3
+ g2(i)= g2(i) + GG2(ip0,jp2,kp3)*a0*b2*c3
+ g2(i)= g2(i) + GG2(ip0,jp3,kp3)*a0*b3*c3
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp3)*a0*b0*c3
+ g3(i)= g3(i) + GG3(ip0,jp1,kp3)*a0*b1*c3
+ g3(i)= g3(i) + GG3(ip0,jp2,kp3)*a0*b2*c3
+ g3(i)= g3(i) + GG3(ip0,jp3,kp3)*a0*b3*c3
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp3)*a1*b0*c3
+ g1(i)= g1(i) + GG1(ip1,jp1,kp3)*a1*b1*c3
+ g1(i)= g1(i) + GG1(ip1,jp2,kp3)*a1*b2*c3
+ g1(i)= g1(i) + GG1(ip1,jp3,kp3)*a1*b3*c3
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp3)*a1*b0*c3
+ g2(i)= g2(i) + GG2(ip1,jp1,kp3)*a1*b1*c3
+ g2(i)= g2(i) + GG2(ip1,jp2,kp3)*a1*b2*c3
+ g2(i)= g2(i) + GG2(ip1,jp3,kp3)*a1*b3*c3
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp3)*a1*b0*c3
+ g3(i)= g3(i) + GG3(ip1,jp1,kp3)*a1*b1*c3
+ g3(i)= g3(i) + GG3(ip1,jp2,kp3)*a1*b2*c3
+ g3(i)= g3(i) + GG3(ip1,jp3,kp3)*a1*b3*c3
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp3)*a2*b0*c3
+ g1(i)= g1(i) + GG1(ip2,jp1,kp3)*a2*b1*c3
+ g1(i)= g1(i) + GG1(ip2,jp2,kp3)*a2*b2*c3
+ g1(i)= g1(i) + GG1(ip2,jp3,kp3)*a2*b3*c3
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp3)*a2*b0*c3
+ g2(i)= g2(i) + GG2(ip2,jp1,kp3)*a2*b1*c3
+ g2(i)= g2(i) + GG2(ip2,jp2,kp3)*a2*b2*c3
+ g2(i)= g2(i) + GG2(ip2,jp3,kp3)*a2*b3*c3
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp3)*a2*b0*c3
+ g3(i)= g3(i) + GG3(ip2,jp1,kp3)*a2*b1*c3
+ g3(i)= g3(i) + GG3(ip2,jp2,kp3)*a2*b2*c3
+ g3(i)= g3(i) + GG3(ip2,jp3,kp3)*a2*b3*c3
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp3)*a3*b0*c3
+ g1(i)= g1(i) + GG1(ip3,jp1,kp3)*a3*b1*c3
+ g1(i)= g1(i) + GG1(ip3,jp2,kp3)*a3*b2*c3
+ g1(i)= g1(i) + GG1(ip3,jp3,kp3)*a3*b3*c3
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp3)*a3*b0*c3
+ g2(i)= g2(i) + GG2(ip3,jp1,kp3)*a3*b1*c3
+ g2(i)= g2(i) + GG2(ip3,jp2,kp3)*a3*b2*c3
+ g2(i)= g2(i) + GG2(ip3,jp3,kp3)*a3*b3*c3
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp3)*a3*b0*c3
+ g3(i)= g3(i) + GG3(ip3,jp1,kp3)*a3*b1*c3
+ g3(i)= g3(i) + GG3(ip3,jp2,kp3)*a3*b2*c3
+ g3(i)= g3(i) + GG3(ip3,jp3,kp3)*a3*b3*c3
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/intervm4.f90 b/CodesEnVrac/CodeGH/src-THI/intervm4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c9511fabee461f882ba11c032a4bdd20710ca5cc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/intervm4.f90
@@ -0,0 +1,375 @@
+!
+SUBROUTINE intervm4(npart,g1,g2,g3,xp,yp,zp)
+
+ !
+ ! Interpolation routine with M'4
+ !
+ ! geometry=unit box, periodic in x and y
+ ! last ponits in z direction assume extension by continuity
+ ! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+ !----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+
+ dy1=dx1
+ dz1=dx1
+
+ do i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+ end do
+
+ dxinv=1./dx1
+ dyinv=1./dy1
+ dzinv=1./dz1
+ dh3=dx1*dy1*dz1
+ dhinv3=1./dh3
+
+ !--------------------------------------------------------------------
+ !- PART II : Determination of the circulation of each particle
+ !--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+
+ DO i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+
+ ! get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx1-x0)*dxinv
+ yy1 = (y - float(jp1)*dy1-y0)*dyinv
+ zz1 = (z - float(kp1)*dz1-z0)*dzinv
+
+ xx0=xx1+1
+ yy0=yy1+1
+ zz0=zz1+1
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+ xx3=2-xx1
+ yy3=2-yy1
+ zz3=2-zz1
+
+
+ !
+ ! on repositionne les points de grille par periodicite
+ ! entre 0 et m-1, puis on numerote de 1 a m
+ C
+ ip1=mod(ip1+nx1,nx1) +1
+ ip0=mod(ip0+nx1,nx1) +1
+ ip2=mod(ip2+nx1,nx1) +1
+ ip3=mod(ip3+nx1,nx1) +1
+
+ ! print*,ip0,ip1,ip2,ip3
+
+ jp1=mod(jp1+ny1,ny1) +1
+ jp0=mod(jp0+ny1,ny1) +1
+ jp2=mod(jp2+ny1,ny1) +1
+ jp3=mod(jp3+ny1,ny1) +1
+
+ kp1=mod(kp1+nz1,nz1) +1
+ kp0=mod(kp0+nz1,nz1) +1
+ kp2=mod(kp2+nz1,nz1) +1
+ kp3=mod(kp3+nz1,nz1) +1
+
+ !
+ ! The M'4 scheme
+ !
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp0)*a0*b0*c0
+ g1(i)= g1(i) + GG1(ip0,jp1,kp0)*a0*b1*c0
+ g1(i)= g1(i) + GG1(ip0,jp2,kp0)*a0*b2*c0
+ g1(i)= g1(i) + GG1(ip0,jp3,kp0)*a0*b3*c0
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp0)*a0*b0*c0
+ g2(i)= g2(i) + GG2(ip0,jp1,kp0)*a0*b1*c0
+ g2(i)= g2(i) + GG2(ip0,jp2,kp0)*a0*b2*c0
+ g2(i)= g2(i) + GG2(ip0,jp3,kp0)*a0*b3*c0
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp0)*a0*b0*c0
+ g3(i)= g3(i) + GG3(ip0,jp1,kp0)*a0*b1*c0
+ g3(i)= g3(i) + GG3(ip0,jp2,kp0)*a0*b2*c0
+ g3(i)= g3(i) + GG3(ip0,jp3,kp0)*a0*b3*c0
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp0)*a1*b0*c0
+ g1(i)= g1(i) + GG1(ip1,jp1,kp0)*a1*b1*c0
+ g1(i)= g1(i) + GG1(ip1,jp2,kp0)*a1*b2*c0
+ g1(i)= g1(i) + GG1(ip1,jp3,kp0)*a1*b3*c0
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp0)*a1*b0*c0
+ g2(i)= g2(i) + GG2(ip1,jp1,kp0)*a1*b1*c0
+ g2(i)= g2(i) + GG2(ip1,jp2,kp0)*a1*b2*c0
+ g2(i)= g2(i) + GG2(ip1,jp3,kp0)*a1*b3*c0
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp0)*a1*b0*c0
+ g3(i)= g3(i) + GG3(ip1,jp1,kp0)*a1*b1*c0
+ g3(i)= g3(i) + GG3(ip1,jp2,kp0)*a1*b2*c0
+ g3(i)= g3(i) + GG3(ip1,jp3,kp0)*a1*b3*c0
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp0)*a2*b0*c0
+ g1(i)= g1(i) + GG1(ip2,jp1,kp0)*a2*b1*c0
+ g1(i)= g1(i) + GG1(ip2,jp2,kp0)*a2*b2*c0
+ g1(i)= g1(i) + GG1(ip2,jp3,kp0)*a2*b3*c0
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp0)*a2*b0*c0
+ g2(i)= g2(i) + GG2(ip2,jp1,kp0)*a2*b1*c0
+ g2(i)= g2(i) + GG2(ip2,jp2,kp0)*a2*b2*c0
+ g2(i)= g2(i) + GG2(ip2,jp3,kp0)*a2*b3*c0
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp0)*a2*b0*c0
+ g3(i)= g3(i) + GG3(ip2,jp1,kp0)*a2*b1*c0
+ g3(i)= g3(i) + GG3(ip2,jp2,kp0)*a2*b2*c0
+ g3(i)= g3(i) + GG3(ip2,jp3,kp0)*a2*b3*c0
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp0)*a3*b0*c0
+ g1(i)= g1(i) + GG1(ip3,jp1,kp0)*a3*b1*c0
+ g1(i)= g1(i) + GG1(ip3,jp2,kp0)*a3*b2*c0
+ g1(i)= g1(i) + GG1(ip3,jp3,kp0)*a3*b3*c0
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp0)*a3*b0*c0
+ g2(i)= g2(i) + GG2(ip3,jp1,kp0)*a3*b1*c0
+ g2(i)= g2(i) + GG2(ip3,jp2,kp0)*a3*b2*c0
+ g2(i)= g2(i) + GG2(ip3,jp3,kp0)*a3*b3*c0
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp0)*a3*b0*c0
+ g3(i)= g3(i) + GG3(ip3,jp1,kp0)*a3*b1*c0
+ g3(i)= g3(i) + GG3(ip3,jp2,kp0)*a3*b2*c0
+ g3(i)= g3(i) + GG3(ip3,jp3,kp0)*a3*b3*c0
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp1)*a0*b0*c1
+ g1(i)= g1(i) + GG1(ip0,jp1,kp1)*a0*b1*c1
+ g1(i)= g1(i) + GG1(ip0,jp2,kp1)*a0*b2*c1
+ g1(i)= g1(i) + GG1(ip0,jp3,kp1)*a0*b3*c1
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp1)*a0*b0*c1
+ g2(i)= g2(i) + GG2(ip0,jp1,kp1)*a0*b1*c1
+ g2(i)= g2(i) + GG2(ip0,jp2,kp1)*a0*b2*c1
+ g2(i)= g2(i) + GG2(ip0,jp3,kp1)*a0*b3*c1
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp1)*a0*b0*c1
+ g3(i)= g3(i) + GG3(ip0,jp1,kp1)*a0*b1*c1
+ g3(i)= g3(i) + GG3(ip0,jp2,kp1)*a0*b2*c1
+ g3(i)= g3(i) + GG3(ip0,jp3,kp1)*a0*b3*c1
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp1)*a1*b0*c1
+ g1(i)= g1(i) + GG1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + GG1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + GG1(ip1,jp3,kp1)*a1*b3*c1
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp1)*a1*b0*c1
+ g2(i)= g2(i) + GG2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + GG2(ip1,jp2,kp1)*a1*b2*c1
+ g2(i)= g2(i) + GG2(ip1,jp3,kp1)*a1*b3*c1
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp1)*a1*b0*c1
+ g3(i)= g3(i) + GG3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + GG3(ip1,jp2,kp1)*a1*b2*c1
+ g3(i)= g3(i) + GG3(ip1,jp3,kp1)*a1*b3*c1
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp1)*a2*b0*c1
+ g1(i)= g1(i) + GG1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + GG1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + GG1(ip2,jp3,kp1)*a2*b3*c1
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp1)*a2*b0*c1
+ g2(i)= g2(i) + GG2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + GG2(ip2,jp2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + GG2(ip2,jp3,kp1)*a2*b3*c1
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp1)*a2*b0*c1
+ g3(i)= g3(i) + GG3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + GG3(ip2,jp2,kp1)*a2*b2*c1
+ g3(i)= g3(i) + GG3(ip2,jp3,kp1)*a2*b3*c1
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp1)*a3*b0*c1
+ g1(i)= g1(i) + GG1(ip3,jp1,kp1)*a3*b1*c1
+ g1(i)= g1(i) + GG1(ip3,jp2,kp1)*a3*b2*c1
+ g1(i)= g1(i) + GG1(ip3,jp3,kp1)*a3*b3*c1
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp1)*a3*b0*c1
+ g2(i)= g2(i) + GG2(ip3,jp1,kp1)*a3*b1*c1
+ g2(i)= g2(i) + GG2(ip3,jp2,kp1)*a3*b2*c1
+ g2(i)= g2(i) + GG2(ip3,jp3,kp1)*a3*b3*c1
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp1)*a3*b0*c1
+ g3(i)= g3(i) + GG3(ip3,jp1,kp1)*a3*b1*c1
+ g3(i)= g3(i) + GG3(ip3,jp2,kp1)*a3*b2*c1
+ g3(i)= g3(i) + GG3(ip3,jp3,kp1)*a3*b3*c1
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp2)*a0*b0*c2
+ g1(i)= g1(i) + GG1(ip0,jp1,kp2)*a0*b1*c2
+ g1(i)= g1(i) + GG1(ip0,jp2,kp2)*a0*b2*c2
+ g1(i)= g1(i) + GG1(ip0,jp3,kp2)*a0*b3*c2
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp2)*a0*b0*c2
+ g2(i)= g2(i) + GG2(ip0,jp1,kp2)*a0*b1*c2
+ g2(i)= g2(i) + GG2(ip0,jp2,kp2)*a0*b2*c2
+ g2(i)= g2(i) + GG2(ip0,jp3,kp2)*a0*b3*c2
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp2)*a0*b0*c2
+ g3(i)= g3(i) + GG3(ip0,jp1,kp2)*a0*b1*c2
+ g3(i)= g3(i) + GG3(ip0,jp2,kp2)*a0*b2*c2
+ g3(i)= g3(i) + GG3(ip0,jp3,kp2)*a0*b3*c2
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp2)*a1*b0*c2
+ g1(i)= g1(i) + GG1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + GG1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + GG1(ip1,jp3,kp2)*a1*b3*c2
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp2)*a1*b0*c2
+ g2(i)= g2(i) + GG2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + GG2(ip1,jp2,kp2)*a1*b2*c2
+ g2(i)= g2(i) + GG2(ip1,jp3,kp2)*a1*b3*c2
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp2)*a1*b0*c2
+ g3(i)= g3(i) + GG3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + GG3(ip1,jp2,kp2)*a1*b2*c2
+ g3(i)= g3(i) + GG3(ip1,jp3,kp2)*a1*b3*c2
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp2)*a2*b0*c2
+ g1(i)= g1(i) + GG1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + GG1(ip2,jp2,kp2)*a2*b2*c2
+ g1(i)= g1(i) + GG1(ip2,jp3,kp2)*a2*b3*c2
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp2)*a2*b0*c2
+ g2(i)= g2(i) + GG2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + GG2(ip2,jp2,kp2)*a2*b2*c2
+ g2(i)= g2(i) + GG2(ip2,jp3,kp2)*a2*b3*c2
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp2)*a2*b0*c2
+ g3(i)= g3(i) + GG3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + GG3(ip2,jp2,kp2)*a2*b2*c2
+ g3(i)= g3(i) + GG3(ip2,jp3,kp2)*a2*b3*c2
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp2)*a3*b0*c2
+ g1(i)= g1(i) + GG1(ip3,jp1,kp2)*a3*b1*c2
+ g1(i)= g1(i) + GG1(ip3,jp2,kp2)*a3*b2*c2
+ g1(i)= g1(i) + GG1(ip3,jp3,kp2)*a3*b3*c2
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp2)*a3*b0*c2
+ g2(i)= g2(i) + GG2(ip3,jp1,kp2)*a3*b1*c2
+ g2(i)= g2(i) + GG2(ip3,jp2,kp2)*a3*b2*c2
+ g2(i)= g2(i) + GG2(ip3,jp3,kp2)*a3*b3*c2
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp2)*a3*b0*c2
+ g3(i)= g3(i) + GG3(ip3,jp1,kp2)*a3*b1*c2
+ g3(i)= g3(i) + GG3(ip3,jp2,kp2)*a3*b2*c2
+ g3(i)= g3(i) + GG3(ip3,jp3,kp2)*a3*b3*c2
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp3)*a0*b0*c3
+ g1(i)= g1(i) + GG1(ip0,jp1,kp3)*a0*b1*c3
+ g1(i)= g1(i) + GG1(ip0,jp2,kp3)*a0*b2*c3
+ g1(i)= g1(i) + GG1(ip0,jp3,kp3)*a0*b3*c3
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp3)*a0*b0*c3
+ g2(i)= g2(i) + GG2(ip0,jp1,kp3)*a0*b1*c3
+ g2(i)= g2(i) + GG2(ip0,jp2,kp3)*a0*b2*c3
+ g2(i)= g2(i) + GG2(ip0,jp3,kp3)*a0*b3*c3
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp3)*a0*b0*c3
+ g3(i)= g3(i) + GG3(ip0,jp1,kp3)*a0*b1*c3
+ g3(i)= g3(i) + GG3(ip0,jp2,kp3)*a0*b2*c3
+ g3(i)= g3(i) + GG3(ip0,jp3,kp3)*a0*b3*c3
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp3)*a1*b0*c3
+ g1(i)= g1(i) + GG1(ip1,jp1,kp3)*a1*b1*c3
+ g1(i)= g1(i) + GG1(ip1,jp2,kp3)*a1*b2*c3
+ g1(i)= g1(i) + GG1(ip1,jp3,kp3)*a1*b3*c3
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp3)*a1*b0*c3
+ g2(i)= g2(i) + GG2(ip1,jp1,kp3)*a1*b1*c3
+ g2(i)= g2(i) + GG2(ip1,jp2,kp3)*a1*b2*c3
+ g2(i)= g2(i) + GG2(ip1,jp3,kp3)*a1*b3*c3
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp3)*a1*b0*c3
+ g3(i)= g3(i) + GG3(ip1,jp1,kp3)*a1*b1*c3
+ g3(i)= g3(i) + GG3(ip1,jp2,kp3)*a1*b2*c3
+ g3(i)= g3(i) + GG3(ip1,jp3,kp3)*a1*b3*c3
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp3)*a2*b0*c3
+ g1(i)= g1(i) + GG1(ip2,jp1,kp3)*a2*b1*c3
+ g1(i)= g1(i) + GG1(ip2,jp2,kp3)*a2*b2*c3
+ g1(i)= g1(i) + GG1(ip2,jp3,kp3)*a2*b3*c3
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp3)*a2*b0*c3
+ g2(i)= g2(i) + GG2(ip2,jp1,kp3)*a2*b1*c3
+ g2(i)= g2(i) + GG2(ip2,jp2,kp3)*a2*b2*c3
+ g2(i)= g2(i) + GG2(ip2,jp3,kp3)*a2*b3*c3
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp3)*a2*b0*c3
+ g3(i)= g3(i) + GG3(ip2,jp1,kp3)*a2*b1*c3
+ g3(i)= g3(i) + GG3(ip2,jp2,kp3)*a2*b2*c3
+ g3(i)= g3(i) + GG3(ip2,jp3,kp3)*a2*b3*c3
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp3)*a3*b0*c3
+ g1(i)= g1(i) + GG1(ip3,jp1,kp3)*a3*b1*c3
+ g1(i)= g1(i) + GG1(ip3,jp2,kp3)*a3*b2*c3
+ g1(i)= g1(i) + GG1(ip3,jp3,kp3)*a3*b3*c3
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp3)*a3*b0*c3
+ g2(i)= g2(i) + GG2(ip3,jp1,kp3)*a3*b1*c3
+ g2(i)= g2(i) + GG2(ip3,jp2,kp3)*a3*b2*c3
+ g2(i)= g2(i) + GG2(ip3,jp3,kp3)*a3*b3*c3
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp3)*a3*b0*c3
+ g3(i)= g3(i) + GG3(ip3,jp1,kp3)*a3*b1*c3
+ g3(i)= g3(i) + GG3(ip3,jp2,kp3)*a3*b2*c3
+ g3(i)= g3(i) + GG3(ip3,jp3,kp3)*a3*b3*c3
+
+ end DO
+
+end SUBROUTINE intervm4
diff --git a/CodesEnVrac/CodeGH/src-THI/main.f b/CodesEnVrac/CodeGH/src-THI/main.f
new file mode 100644
index 0000000000000000000000000000000000000000..a29a6832de25d43705ce5d87d6765a5056b72b52
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/main.f
@@ -0,0 +1,419 @@
+ program cylindre
+
+c versnio de main avec splitting x,y,z du transport/remesh de rho
+c le poussuer/remaille de om et rho sont dissocies
+c comma main_full, mais avec cfl 0.5 pour advection de rho
+c (et possibilite de sous-ite pour advection de rho avec dt3 < dt)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(npm),yp1(npm),zp1(npm),dv1(npm)
+ dimension xp2(npm),yp2(npm),zp2(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx1(npm),vy1(npm),vz1(npm)
+ dimension vx2(npm),vy2(npm),vz2(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+ dimension phip(npm)
+c tableuax supplementaries pour RK
+ dimension xp10(npm),yp10(npm),zp10(npm)
+ dimension xp20(npm),yp20(npm),zp20(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv1(4,npm),vyv1(4,npm),vzv1(4,npm)
+ dimension vxv2(4,npm),vyv2(4,npm),vzv2(4,npm)
+
+ dimension para(4)
+ dimension enstrophy(0:10000),energy(0:10000),divergence(0:10000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filerho,fileomx,fileomy,fileomz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx1
+ READ(1,*)
+ read(1,*) nx2
+ READ(1,*)
+ read(1,*)nit
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)anu_rho
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)korder
+ READ(1,*)
+ read(1,*)tstop
+ close(1)
+ idif=1
+ iper=0
+
+
+ xmin=0.
+ ymin=0.
+ zmin=0.
+ xmax=pi2
+ xmax=1.
+ ymax=xmax
+ dx1=xmax/float(nx1)
+ dx2=xmax/float(nx2)
+ zmax=xmax
+
+ t1=4.5
+ t2=5.
+ t3=5.5
+c t3=0.784
+c t4=1.13
+c t3=1000.
+ t4=1000.
+
+c t1=3.4
+c t2=3.8
+c t3=3.6
+c t4=6.
+c resolution pour rho
+c et initalisation des comptuer utlise pour
+c avoir des pas de temps distincts en rho et omega
+
+ nx3=32
+c cas ou on utilise veloxax_v2 (filtre en spectral
+c puis on padde avec des 0 puis on fftinverse sur une
+c grille 128:
+ nx3=nx1
+
+ dx3=xmax/float(nx3)
+ ic=0
+ k_delt3=1
+
+ dy1=dx1
+ dz1=dx1
+ ny1=nint(float(nx1)*ymax/xmax)
+ nz1=nint(float(nx1)*zmax/xmax)
+ ymax=float(ny1)*dy1
+ zmax=float(nz1)*dz1
+ dy2=dx2
+ dz2=dx2
+ ny2=nint(float(nx2)*ymax/xmax)
+ nz2=nint(float(nx2)*zmax/xmax)
+
+ print*, nx1,ny1,nz1,xmax,ymax,zmax
+
+
+ delt0=1.5*dx1
+ delt0=0.0001
+ delt=delt0
+ delt3=delt
+c delt=0.0
+
+c call readfield(npart1,xp1,yp1,zp1,
+c 1 omx,omy,omz,dv1)
+ call jet(npart1,xp1,yp1,zp1,
+ 1 omx,omy,omz,dv1)
+
+ print*,'npart1 ',npart1
+
+ OPEN(33,file='DIAG1',status='unknown')
+ OPEN(34,file='DIAG2',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ omax=1000.
+ istep=0
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ call velox(vmax1)
+ call veloxaux(vmax,dvmax)
+
+c determination pas de temps:
+ if ((ic.eq.0)) then
+ delt=.25/abs(omax)
+ delt=amax1(delt,0.5*dx1/vmax1)
+c delt=0.5*dx2/vmax
+ delt3=2.*dx3/vmax
+ delt3=0.5*dx2/vmax
+ delt3=1.*delt
+ if (dvmax.ne.0.) delt3=amax1(delt3,0.25/dvmax)
+c if ((dvmax.ne.0.).and.(korder.eq.2))
+c 1 delt3=amax1(delt3,0.5*dx3/dvmax)
+c delt3=delt
+ print*, ' TIME, Pas de temps omega et rho ', time,delt,delt3
+ print*, 'dvmax',dvmax
+ print*, ' LCFL ',dvmax*delt3
+ k_delt3=int(delt3/delt)
+ if (k_delt3.eq.0) then
+ k_delt=int(delt/delt3)
+ k_delt3=1
+ k_delt=k_delt+1
+ delt3=delt/float(k_delt)
+ else
+ delt3=float(k_delt3)*delt
+ k_delt=1
+ endif
+ print*,' CFLs ',delt3*vmax/dx3,delt3*vmax/dx2
+ endif
+
+ deltconv=delt
+
+ delt1=deltconv/6.
+
+c ADVECTION particules de vorticite
+
+c on fait les sous-iterations R.K.
+
+ do i=1,npart1
+ xp10(i)=xp1(i)
+ yp10(i)=yp1(i)
+ zp10(i)=zp1(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+ enddo
+
+ do 550 ll=1,4
+
+ if (ll.eq.1) then
+
+ print*,'TIME ',time
+
+ call stretch
+
+ endif
+
+ nx4=nx1
+
+ call intervm4(npart1,vx1,vy1,vz1,xp1,yp1,zp1)
+ call intersm4(npart1,strx,stry,strz,xp1,yp1,zp1)
+
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ do 520 i=1,npart1
+ vxv1(ll,i)=vx1(i)
+ vyv1(ll,i)=vy1(i)
+ vzv1(ll,i)=vz1(i)
+ strxv(ll,i)=dv1(i)*strx(i)
+ stryv(ll,i)=dv1(i)*stry(i)
+ strzv(ll,i)=dv1(i)*strz(i)
+ xp1(i)=xp10(i)+para(ll)*deltconv*vx1(i)
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ yp1(i)=yp10(i)+para(ll)*deltconv*vy1(i)
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ zp1(i)=zp10(i)+para(ll)*deltconv*vz1(i)
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv1(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv1(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv1(i)*strz(i)
+ vxmax=amax1(vxmax,(vx1(i)))
+ vxmin=amin1(vxmin,(vx1(i)))
+ vymax=amax1(vymax,(vy1(i)))
+ vymin=amin1(vymin,(vy1(i)))
+ vzmax=amax1(vzmax,(vz1(i)))
+ vzmin=amin1(vzmin,(vz1(i)))
+520 continue
+
+550 continue
+
+c FIN des sous-ite RK pour transport de vorticite
+c **********************
+
+ xpmin=10.
+ ypmin=10.
+ xpmax=0.
+ ypmax=0.
+ yleft=1000.
+ yright=-1000.
+
+ do i=1,npart1
+ xp1(i)=xp10(i)+delt1*
+ 1 (vxv1(1,i)+2.*vxv1(2,i)+2.*vxv1(3,i)+vxv1(4,i))
+ yp1(i)=yp10(i)+delt1*
+ 1 (vyv1(1,i)+2.*vyv1(2,i)+2.*vyv1(3,i)+vyv1(4,i))
+ zp1(i)=zp10(i)+delt1*
+ 1 (vzv1(1,i)+2.*vzv1(2,i)+2.*vzv1(3,i)+vzv1(4,i))
+ if (xp1(i).lt.xmin) xp1(i)=xp1(i)+xmax-xmin
+ if (xp1(i).gt.xmax) xp1(i)=xp1(i)-xmax+xmin
+ if (yp1(i).lt.ymin) yp1(i)=yp1(i)+ymax-ymin
+ if (yp1(i).gt.ymax) yp1(i)=yp1(i)-ymax+ymin
+ if (zp1(i).lt.zmin) zp1(i)=zp1(i)+zmax-zmin
+ if (zp1(i).gt.zmax) zp1(i)=zp1(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+ enddo
+
+700 continue
+
+c fin d'adection de particules de vorticite
+
+
+c
+
+c Remesh des particules de vorticite
+C puis diffusion de vorticite
+c **********************
+
+ circlim=+0.0001
+c circlim=0.
+
+ call remesh_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1)
+ print*,' npart OM apres remeshing ', kk,npart1
+ call dif_om(npart1,omx,omy,omz,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax)
+4444 continue
+
+c icrementation du comptuer pour decider ou non d
+c d'advecter/remailler en rho (pas de temps disticnts)
+ ic=ic+1
+ do 111 ksubite=1,k_delt
+ print*,ic,k_delt3
+ if ((ic.eq.k_delt3)) then
+
+ np_bl=3
+ dx=dx2
+ nx=nx2
+ dt=delt3
+ dt2=delt3/2.
+ dt3=delt3/2.
+
+ if (korder.eq.2) then
+ call y_advect(dt2,np_bl,ntagy)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call z_advect(dt2,np_bl,ntagz)
+ call z_advect(dt2,np_bl,ntagz)
+ call x_advect(dt3,np_bl,npart_rho,ntagx)
+ call y_advect(dt2,np_bl,ntagy)
+ else
+ call x_advect(dt,np_bl,npart_rho,ntagx)
+ call y_advect(dt,np_bl,ntagy)
+ call z_advect(dt,np_bl,ntagz)
+ endif
+
+
+ ntag=max(ntagx,ntagy)
+ ntag=max(ntag,ntagz)
+
+ call dif_rho(anu_rho,dt)
+
+c Fin de push / remesh rho /dif rho
+ ic=0
+
+c quelques diagnostiques
+ call diag(ener,enstro,div,omax,rhomax,width,VOL1,VOL2)
+ write(33,*) time,npart_rho,ntag,vmax*CFL,enstro
+ write(34,*) time,width,VOL1,VOL2
+
+ endif
+111 continue
+
+ tcompt=tcompt+delt
+ if (((time.gt.t1).and.(time.le.t1+1.5*delt)).
+ 1 or.((time.gt.t2).and.(time.le.t2+1.5*delt)).
+ 1 or.((time.gt.t4).and.(time.le.t4+1.5*delt)).
+ 1 or.((time.gt.t3).and.(time.le.t3+1.5*delt))) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, '*'
+ write(filerho,140)istep
+140 format('rho',i1)
+ write(fileomx,141)istep
+141 format('omx',i1)
+ write(fileomy,142)istep
+142 format('omy',i1)
+ write(fileomz,143)istep
+143 format('omz',i1)
+
+ goto 222
+ open(20,file=filerho,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(2,file=fileomx,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=fileomy,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=fileomz,form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+
+
+ write(20) (((ug(i,j,k),
+ 1 i=1,nx2),j=1,ny2),k=1,nz2)
+ write(2) ((((omg1(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(3) ((((omg2(i,j,k)),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ write(4) (((omg3(i,j,k),
+ 1 i=1,nx1),j=1,ny1),k=1,nz1)
+ close(20)
+ close(2)
+ close(3)
+ close(4)
+ goto 223
+222 continue
+
+ open(24,file=filerho)
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx2," ",nx2," ",nx2
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx2," ",dx2," ",dx2
+ WRITE(24,*) "POINT_DATA ",nx2*nx2*nx2
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx2
+ do j=1,nx2
+ do i=1,nx2
+ umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,ug(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+ print*,'**** RHO MAX = ',umax
+
+223 continue
+
+ endif
+
+ if (time.gt.tstop) goto 202
+
+20 continue
+
+202 continue
+
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/make b/CodesEnVrac/CodeGH/src-THI/make
new file mode 100644
index 0000000000000000000000000000000000000000..4667b6e48da757acf4890b7d5573af17acff9ecf
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/make
@@ -0,0 +1,11 @@
+ 128 128 128 1.000000 1.000000
+ 1.000000
+ VXMAX = 1.291362
+ NPART = 791552
+ npart1 791552
+ VXMAX sur grille 0.9833295 0.1099195 1.6970979E-02
+ umax 0.9903467 9.3841553E-02 3.0463261E-03
+ TIME, Pas de temps omega et rho 9.9999997E-05 1.9862365E-03 1.9721629E-03
+ LCFL 4.6338923E-03
+ CFLs 3.1473007E-02 0.2517841
+ TIME 9.9999997E-05
diff --git a/CodesEnVrac/CodeGH/src-THI/makefile b/CodesEnVrac/CodeGH/src-THI/makefile
new file mode 100644
index 0000000000000000000000000000000000000000..15b43118048913a0ff3a7d72568a0a5f190fcb5e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/makefile
@@ -0,0 +1,112 @@
+#
+# la commande f77 pour les dec est f77_520
+#
+OPT = -I/sw/include
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+#OPT3 = -O3 -r8 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+#OPT3 = -O -p
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = thi_l2
+
+all: $(PROGRAM)
+
+OBJSF = diag.o\
+ initread.o \
+ initjet.o \
+ intervm4.o \
+ intersm4.o \
+ interho.o \
+ main.o \
+ dif.o \
+ dif_rho.o \
+ remesh_om.o \
+ remesh_rho.o \
+ remeshx.o \
+ remeshy.o \
+ remeshz.o \
+ remeshx_tag.o \
+ remeshy_tag.o \
+ remeshz_tag.o \
+ tag_particles.o \
+ x_advect.o \
+ y_advect.o \
+ z_advect.o \
+ stretch.o \
+ fftw3d.o \
+ velox_x.o \
+ velox_y.o \
+ velox_z.o \
+ veloxaux.o \
+ velox.o
+
+diag.o: diag.f param.i
+ ifort $(OPT3) -c diag.f
+dif.o: dif.f param.i
+ ifort $(OPT3) -c dif.f
+dif_rho.o: dif_rho.f param.i
+ ifort $(OPT3) -c dif_rho.f
+initread.o: initread.f param.i
+ ifort $(OPT3) -c -g initread.f
+initjet.o: initjet.f param.i
+ ifort $(OPT3) -c -g initjet.f
+intervm4.o: intervm4.f param.i
+ ifort $(OPT3) -c intervm4.f
+intersm4.o: intersm4.f param.i
+ ifort $(OPT3) -c intersm4.f
+interho.o: interho.f param.i
+ ifort $(OPT3) -c interho.f
+main.o: main.f param.i
+ ifort $(OPT3) -c -g main.f
+remesh_om.o: remesh_om.f param.i
+ ifort $(OPT3) -c remesh_om.f
+remesh_rho.o: remesh_rho.f param.i
+ ifort $(OPT3) -c remesh_rho.f
+remeshx.o: remeshx.f param.i
+ ifort $(OPT3) -c remeshx.f
+remeshy.o: remeshy.f param.i
+ ifort $(OPT3) -c remeshy.f
+remeshz.o: remeshz.f param.i
+ ifort $(OPT3) -c remeshz.f
+remeshx_tag.o: remeshx_tag.f param.i
+ ifort $(OPT3) -c remeshx_tag.f
+remeshy_tag.o: remeshy_tag.f param.i
+ ifort $(OPT3) -c remeshy_tag.f
+remeshz_tag.o: remeshz_tag.f param.i
+ ifort $(OPT3) -c remeshz_tag.f
+x_advect.o: x_advect.f param.i
+ ifort $(OPT3) -c x_advect.f
+y_advect.o: y_advect.f param.i
+ ifort $(OPT3) -c y_advect.f
+z_advect.o: z_advect.f param.i
+ ifort $(OPT3) -c z_advect.f
+tag_particles.o: tag_particles.f param.i
+ ifort $(OPT3) -c tag_particles.f
+stretch.o: stretch.f param.i
+ ifort $(OPT3) -c stretch.f
+velox.o: velox.f param.i
+ ifort $(OPT3) -c velox.f
+velox_x.o: velox_x.f param.i
+ ifort $(OPT3) -c velox_x.f
+velox_y.o: velox_y.f param.i
+ ifort $(OPT3) -c velox_y.f
+velox_z.o: velox_z.f param.i
+ ifort $(OPT3) -c velox_z.f
+veloxaux.o: veloxaux.f param.i
+ ifort $(OPT3) -c veloxaux.f
+fftw3d.o: fftw3d.f param.i
+ ifort $(OPT3) -c fftw3d.f
+
+
+$(PROGRAM): $(OBJSF)
+ ifort $(OPT3) $(OBJSF) -lfftw3f -lfftw3_threads -o $(PROGRAM)
+
diff --git a/CodesEnVrac/CodeGH/src-THI/param.h b/CodesEnVrac/CodeGH/src-THI/param.h
new file mode 100644
index 0000000000000000000000000000000000000000..e6e8a2c9debc539b335a89f3defbbcaef4c4f233
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/param.h
@@ -0,0 +1,3 @@
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,dx1
+ common nx2,ny2,nz2,dx2,nx3
+ common circlim,cfl,nx,dx
\ No newline at end of file
diff --git a/CodesEnVrac/CodeGH/src-THI/param_rho.i b/CodesEnVrac/CodeGH/src-THI/param_rho.i
new file mode 100644
index 0000000000000000000000000000000000000000..58afe3b17798373fbb268914d5291b14cdab41c5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/param_rho.i
@@ -0,0 +1,3 @@
+ parameter(npgx=256,npgy=256,npgz=256)
+ parameter(npg=256)
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remesh_om.f90 b/CodesEnVrac/CodeGH/src-THI/remesh_om.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d1aefc01da2e59518c9e9671fc8975afd5e28c06
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remesh_om.f90
@@ -0,0 +1,465 @@
+!================================================================
+SUBROUTINE remesh_om(npart,om1,om2,om3,xp1,yp1,zp1,dv1)
+ ! This subroutine asssigns vorticity on a grid
+ !----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+
+
+ do i=1,nx1
+ do j=1,ny1
+ do k=1,nz1
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+ end do
+ end do
+ end do
+
+ dy1=dx1
+ dz1=dx1
+
+ dxinv=1./(dx1)
+ dyinv=dxinv
+ dzinv=dxinv
+
+
+
+ !--------------------------------------------------------------------
+ !- PART II : Determination of the circulation of each particle
+ !--------------------------------------------------------------------
+
+ x0=0.
+ y0=0.
+ z0=0.
+
+ vol=dx1*dx1*dx1
+
+ DO n = 1,npart
+
+ g2 = om1(n)/vol
+ g3 = om2(n)/vol
+ g4 = om3(n)/vol
+
+ x = xp1(n)
+ y = yp1(n)
+ z = zp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+ ! Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx1-x0)*dxinv
+ yy1 = (y - float(jp1)*dy1-y0)*dyinv
+ zz1 = (z - float(kp1)*dz1-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+ !
+ ! on repositionne les points de grille par periodicite
+ ! entre 0 et npx-1, puis on numerote de 1 a npx
+ !
+
+ ip1=mod(ip1+nx1,nx1) +1
+ ip0=mod(ip0+nx1,nx1) +1
+ ip2=mod(ip2+nx1,nx1) +1
+ ip3=mod(ip3+nx1,nx1) +1
+
+ jp1=mod(jp1+ny1,ny1) +1
+ jp0=mod(jp0+ny1,ny1) +1
+ jp2=mod(jp2+ny1,ny1) +1
+ jp3=mod(jp3+ny1,ny1) +1
+
+ kp1=mod(kp1+nz1,nz1) +1
+ kp0=mod(kp0+nz1,nz1) +1
+ kp2=mod(kp2+nz1,nz1) +1
+ kp3=mod(kp3+nz1,nz1) +1
+
+ ! The M'4 scheme
+ !
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ ! b1=1.
+ ! b0=0.
+ ! b2=0.
+ ! b3=0.
+ ! a1=1.
+ ! a0=0.
+ ! a2=0.
+ ! a3=0.
+ ! c1=1.
+ ! c0=0.
+ ! c2=0.
+ ! c3=0.
+
+
+ coef=a0*b0*c0
+ omg1(ip0,jp0,kp0) = omg1(ip0,jp0,kp0) + g2*coef
+ omg2(ip0,jp0,kp0) = omg2(ip0,jp0,kp0) + g3*coef
+ omg3(ip0,jp0,kp0) = omg3(ip0,jp0,kp0) + g4*coef
+
+ coef=a0*b0*c1
+ omg1(ip0,jp0,kp1) = omg1(ip0,jp0,kp1) + g2*coef
+ omg2(ip0,jp0,kp1) = omg2(ip0,jp0,kp1) + g3*coef
+ omg3(ip0,jp0,kp1) = omg3(ip0,jp0,kp1) + g4*coef
+
+ coef=a0*b0*c2
+ omg1(ip0,jp0,kp2) = omg1(ip0,jp0,kp2) + g2*coef
+ omg2(ip0,jp0,kp2) = omg2(ip0,jp0,kp2) + g3*coef
+ omg3(ip0,jp0,kp2) = omg3(ip0,jp0,kp2) + g4*coef
+
+ coef=a0*b0*c3
+ omg1(ip0,jp0,kp3) = omg1(ip0,jp0,kp3) + g2*coef
+ omg2(ip0,jp0,kp3) = omg2(ip0,jp0,kp3) + g3*coef
+ omg3(ip0,jp0,kp3) = omg3(ip0,jp0,kp3) + g4*coef
+
+ coef=a0*b1*c0
+ omg1(ip0,jp1,kp0) = omg1(ip0,jp1,kp0) + g2*coef
+ omg2(ip0,jp1,kp0) = omg2(ip0,jp1,kp0) + g3*coef
+ omg3(ip0,jp1,kp0) = omg3(ip0,jp1,kp0) + g4*coef
+
+ coef=a0*b1*c1
+ omg1(ip0,jp1,kp1) = omg1(ip0,jp1,kp1) + g2*coef
+ omg2(ip0,jp1,kp1) = omg2(ip0,jp1,kp1) + g3*coef
+ omg3(ip0,jp1,kp1) = omg3(ip0,jp1,kp1) + g4*coef
+
+ coef=a0*b1*c2
+ omg1(ip0,jp1,kp2) = omg1(ip0,jp1,kp2) + g2*coef
+ omg2(ip0,jp1,kp2) = omg2(ip0,jp1,kp2) + g3*coef
+ omg3(ip0,jp1,kp2) = omg3(ip0,jp1,kp2) + g4*coef
+
+ coef=a0*b1*c3
+ omg1(ip0,jp1,kp3) = omg1(ip0,jp1,kp3) + g2*coef
+ omg2(ip0,jp1,kp3) = omg2(ip0,jp1,kp3) + g3*coef
+ omg3(ip0,jp1,kp3) = omg3(ip0,jp1,kp3) + g4*coef
+
+ coef=a0*b2*c0
+ omg1(ip0,jp2,kp0) = omg1(ip0,jp2,kp0) + g2*coef
+ omg2(ip0,jp2,kp0) = omg2(ip0,jp2,kp0) + g3*coef
+ omg3(ip0,jp2,kp0) = omg3(ip0,jp2,kp0) + g4*coef
+
+ coef=a0*b2*c1
+ omg1(ip0,jp2,kp1) = omg1(ip0,jp2,kp1) + g2*coef
+ omg2(ip0,jp2,kp1) = omg2(ip0,jp2,kp1) + g3*coef
+ omg3(ip0,jp2,kp1) = omg3(ip0,jp2,kp1) + g4*coef
+
+ coef=a0*b2*c2
+ omg1(ip0,jp2,kp2) = omg1(ip0,jp2,kp2) + g2*coef
+ omg2(ip0,jp2,kp2) = omg2(ip0,jp2,kp2) + g3*coef
+ omg3(ip0,jp2,kp2) = omg3(ip0,jp2,kp2) + g4*coef
+
+
+ coef=a0*b2*c3
+ omg1(ip0,jp2,kp3) = omg1(ip0,jp2,kp3) + g2*coef
+ omg2(ip0,jp2,kp3) = omg2(ip0,jp2,kp3) + g3*coef
+ omg3(ip0,jp2,kp3) = omg3(ip0,jp2,kp3) + g4*coef
+
+ coef=a0*b3*c0
+ omg1(ip0,jp3,kp0) = omg1(ip0,jp3,kp0) + g2*coef
+ omg2(ip0,jp3,kp0) = omg2(ip0,jp3,kp0) + g3*coef
+ omg3(ip0,jp3,kp0) = omg3(ip0,jp3,kp0) + g4*coef
+
+ coef=a0*b3*c1
+ omg1(ip0,jp3,kp1) = omg1(ip0,jp3,kp1) + g2*coef
+ omg2(ip0,jp3,kp1) = omg2(ip0,jp3,kp1) + g3*coef
+ omg3(ip0,jp3,kp1) = omg3(ip0,jp3,kp1) + g4*coef
+
+ coef=a0*b3*c2
+ omg1(ip0,jp3,kp2) = omg1(ip0,jp3,kp2) + g2*coef
+ omg2(ip0,jp3,kp2) = omg2(ip0,jp3,kp2) + g3*coef
+ omg3(ip0,jp3,kp2) = omg3(ip0,jp3,kp2) + g4*coef
+
+ coef=a0*b3*c3
+ omg1(ip0,jp3,kp3) = omg1(ip0,jp3,kp3) + g2*coef
+ omg2(ip0,jp3,kp3) = omg2(ip0,jp3,kp3) + g3*coef
+ omg3(ip0,jp3,kp3) = omg3(ip0,jp3,kp3) + g4*coef
+
+ coef=a1*b0*c0
+ omg1(ip1,jp0,kp0) = omg1(ip1,jp0,kp0) + g2*coef
+ omg2(ip1,jp0,kp0) = omg2(ip1,jp0,kp0) + g3*coef
+ omg3(ip1,jp0,kp0) = omg3(ip1,jp0,kp0) + g4*coef
+
+ coef=a1*b0*c1
+ omg1(ip1,jp0,kp1) = omg1(ip1,jp0,kp1) + g2*coef
+ omg2(ip1,jp0,kp1) = omg2(ip1,jp0,kp1) + g3*coef
+ omg3(ip1,jp0,kp1) = omg3(ip1,jp0,kp1) + g4*coef
+
+ coef=a1*b0*c2
+ omg1(ip1,jp0,kp2) = omg1(ip1,jp0,kp2) + g2*coef
+ omg2(ip1,jp0,kp2) = omg2(ip1,jp0,kp2) + g3*coef
+ omg3(ip1,jp0,kp2) = omg3(ip1,jp0,kp2) + g4*coef
+
+ coef=a1*b0*c3
+ omg1(ip1,jp0,kp3) = omg1(ip1,jp0,kp3) + g2*coef
+ omg2(ip1,jp0,kp3) = omg2(ip1,jp0,kp3) + g3*coef
+ omg3(ip1,jp0,kp3) = omg3(ip1,jp0,kp3) + g4*coef
+
+ coef=a1*b1*c0
+ omg1(ip1,jp1,kp0) = omg1(ip1,jp1,kp0) + g2*coef
+ omg2(ip1,jp1,kp0) = omg2(ip1,jp1,kp0) + g3*coef
+ omg3(ip1,jp1,kp0) = omg3(ip1,jp1,kp0) + g4*coef
+
+ coef=a1*b1*c1
+ omg1(ip1,jp1,kp1) = omg1(ip1,jp1,kp1) + g2*coef
+ omg2(ip1,jp1,kp1) = omg2(ip1,jp1,kp1) + g3*coef
+ omg3(ip1,jp1,kp1) = omg3(ip1,jp1,kp1) + g4*coef
+
+ coef=a1*b1*c2
+ omg1(ip1,jp1,kp2) = omg1(ip1,jp1,kp2) + g2*coef
+ omg2(ip1,jp1,kp2) = omg2(ip1,jp1,kp2) + g3*coef
+ omg3(ip1,jp1,kp2) = omg3(ip1,jp1,kp2) + g4*coef
+
+ coef=a1*b1*c3
+ omg1(ip1,jp1,kp3) = omg1(ip1,jp1,kp3) + g2*coef
+ omg2(ip1,jp1,kp3) = omg2(ip1,jp1,kp3) + g3*coef
+ omg3(ip1,jp1,kp3) = omg3(ip1,jp1,kp3) + g4*coef
+
+ coef=a1*b2*c0
+ omg1(ip1,jp2,kp0) = omg1(ip1,jp2,kp0) + g2*coef
+ omg2(ip1,jp2,kp0) = omg2(ip1,jp2,kp0) + g3*coef
+ omg3(ip1,jp2,kp0) = omg3(ip1,jp2,kp0) + g4*coef
+
+ coef=a1*b2*c1
+ omg1(ip1,jp2,kp1) = omg1(ip1,jp2,kp1) + g2*coef
+ omg2(ip1,jp2,kp1) = omg2(ip1,jp2,kp1) + g3*coef
+ omg3(ip1,jp2,kp1) = omg3(ip1,jp2,kp1) + g4*coef
+
+ coef=a1*b2*c2
+ omg1(ip1,jp2,kp2) = omg1(ip1,jp2,kp2) + g2*coef
+ omg2(ip1,jp2,kp2) = omg2(ip1,jp2,kp2) + g3*coef
+ omg3(ip1,jp2,kp2) = omg3(ip1,jp2,kp2) + g4*coef
+
+ coef=a1*b2*c3
+ omg1(ip1,jp2,kp3) = omg1(ip1,jp2,kp3) + g2*coef
+ omg2(ip1,jp2,kp3) = omg2(ip1,jp2,kp3) + g3*coef
+ omg3(ip1,jp2,kp3) = omg3(ip1,jp2,kp3) + g4*coef
+
+ coef=a1*b3*c0
+ omg1(ip1,jp3,kp0) = omg1(ip1,jp3,kp0) + g2*coef
+ omg2(ip1,jp3,kp0) = omg2(ip1,jp3,kp0) + g3*coef
+ omg3(ip1,jp3,kp0) = omg3(ip1,jp3,kp0) + g4*coef
+
+ coef=a1*b3*c1
+ omg1(ip1,jp3,kp1) = omg1(ip1,jp3,kp1) + g2*coef
+ omg2(ip1,jp3,kp1) = omg2(ip1,jp3,kp1) + g3*coef
+ omg3(ip1,jp3,kp1) = omg3(ip1,jp3,kp1) + g4*coef
+
+ coef=a1*b3*c2
+ omg1(ip1,jp3,kp2) = omg1(ip1,jp3,kp2) + g2*coef
+ omg2(ip1,jp3,kp2) = omg2(ip1,jp3,kp2) + g3*coef
+ omg3(ip1,jp3,kp2) = omg3(ip1,jp3,kp2) + g4*coef
+
+ coef=a1*b3*c3
+ omg1(ip1,jp3,kp3) = omg1(ip1,jp3,kp3) + g2*coef
+ omg2(ip1,jp3,kp3) = omg2(ip1,jp3,kp3) + g3*coef
+ omg3(ip1,jp3,kp3) = omg3(ip1,jp3,kp3) + g4*coef
+
+ coef=a2*b0*c0
+ omg1(ip2,jp0,kp0) = omg1(ip2,jp0,kp0) + g2*coef
+ omg2(ip2,jp0,kp0) = omg2(ip2,jp0,kp0) + g3*coef
+ omg3(ip2,jp0,kp0) = omg3(ip2,jp0,kp0) + g4*coef
+
+ coef=a2*b0*c1
+ omg1(ip2,jp0,kp1) = omg1(ip2,jp0,kp1) + g2*coef
+ omg2(ip2,jp0,kp1) = omg2(ip2,jp0,kp1) + g3*coef
+ omg3(ip2,jp0,kp1) = omg3(ip2,jp0,kp1) + g4*coef
+
+ coef=a2*b0*c2
+ omg1(ip2,jp0,kp2) = omg1(ip2,jp0,kp2) + g2*coef
+ omg2(ip2,jp0,kp2) = omg2(ip2,jp0,kp2) + g3*coef
+ omg3(ip2,jp0,kp2) = omg3(ip2,jp0,kp2) + g4*coef
+
+ coef=a2*b0*c3
+ omg1(ip2,jp0,kp3) = omg1(ip2,jp0,kp3) + g2*coef
+ omg2(ip2,jp0,kp3) = omg2(ip2,jp0,kp3) + g3*coef
+ omg3(ip2,jp0,kp3) = omg3(ip2,jp0,kp3) + g4*coef
+
+ coef=a2*b1*c0
+ omg1(ip2,jp1,kp0) = omg1(ip2,jp1,kp0) + g2*coef
+ omg2(ip2,jp1,kp0) = omg2(ip2,jp1,kp0) + g3*coef
+ omg3(ip2,jp1,kp0) = omg3(ip2,jp1,kp0) + g4*coef
+
+ coef=a2*b1*c1
+ omg1(ip2,jp1,kp1) = omg1(ip2,jp1,kp1) + g2*coef
+ omg2(ip2,jp1,kp1) = omg2(ip2,jp1,kp1) + g3*coef
+ omg3(ip2,jp1,kp1) = omg3(ip2,jp1,kp1) + g4*coef
+
+ coef=a2*b1*c2
+ omg1(ip2,jp1,kp2) = omg1(ip2,jp1,kp2) + g2*coef
+ omg2(ip2,jp1,kp2) = omg2(ip2,jp1,kp2) + g3*coef
+ omg3(ip2,jp1,kp2) = omg3(ip2,jp1,kp2) + g4*coef
+
+ coef=a2*b1*c3
+ omg1(ip2,jp1,kp3) = omg1(ip2,jp1,kp3) + g2*coef
+ omg2(ip2,jp1,kp3) = omg2(ip2,jp1,kp3) + g3*coef
+ omg3(ip2,jp1,kp3) = omg3(ip2,jp1,kp3) + g4*coef
+
+ coef=a2*b2*c0
+ omg1(ip2,jp2,kp0) = omg1(ip2,jp2,kp0) + g2*coef
+ omg2(ip2,jp2,kp0) = omg2(ip2,jp2,kp0) + g3*coef
+ omg3(ip2,jp2,kp0) = omg3(ip2,jp2,kp0) + g4*coef
+
+ coef=a2*b2*c1
+ omg1(ip2,jp2,kp1) = omg1(ip2,jp2,kp1) + g2*coef
+ omg2(ip2,jp2,kp1) = omg2(ip2,jp2,kp1) + g3*coef
+ omg3(ip2,jp2,kp1) = omg3(ip2,jp2,kp1) + g4*coef
+
+ coef=a2*b2*c2
+ omg1(ip2,jp2,kp2) = omg1(ip2,jp2,kp2) + g2*coef
+ omg2(ip2,jp2,kp2) = omg2(ip2,jp2,kp2) + g3*coef
+ omg3(ip2,jp2,kp2) = omg3(ip2,jp2,kp2) + g4*coef
+
+ coef=a2*b2*c3
+ omg1(ip2,jp2,kp3) = omg1(ip2,jp2,kp3) + g2*coef
+ omg2(ip2,jp2,kp3) = omg2(ip2,jp2,kp3) + g3*coef
+ omg3(ip2,jp2,kp3) = omg3(ip2,jp2,kp3) + g4*coef
+
+ coef=a2*b3*c0
+ omg1(ip2,jp3,kp0) = omg1(ip2,jp3,kp0) + g2*coef
+ omg2(ip2,jp3,kp0) = omg2(ip2,jp3,kp0) + g3*coef
+ omg3(ip2,jp3,kp0) = omg3(ip2,jp3,kp0) + g4*coef
+
+ coef=a2*b3*c1
+ omg1(ip2,jp3,kp1) = omg1(ip2,jp3,kp1) + g2*coef
+ omg2(ip2,jp3,kp1) = omg2(ip2,jp3,kp1) + g3*coef
+ omg3(ip2,jp3,kp1) = omg3(ip2,jp3,kp1) + g4*coef
+
+ coef=a2*b3*c2
+ omg1(ip2,jp3,kp2) = omg1(ip2,jp3,kp2) + g2*coef
+ omg2(ip2,jp3,kp2) = omg2(ip2,jp3,kp2) + g3*coef
+ omg3(ip2,jp3,kp2) = omg3(ip2,jp3,kp2) + g4*coef
+
+ coef=a2*b3*c3
+ omg1(ip2,jp3,kp3) = omg1(ip2,jp3,kp3) + g2*coef
+ omg2(ip2,jp3,kp3) = omg2(ip2,jp3,kp3) + g3*coef
+ omg3(ip2,jp3,kp3) = omg3(ip2,jp3,kp3) + g4*coef
+
+ coef=a3*b0*c0
+ omg1(ip3,jp0,kp0) = omg1(ip3,jp0,kp0) + g2*coef
+ omg2(ip3,jp0,kp0) = omg2(ip3,jp0,kp0) + g3*coef
+ omg3(ip3,jp0,kp0) = omg3(ip3,jp0,kp0) + g4*coef
+
+ coef=a3*b0*c1
+ omg1(ip3,jp0,kp1) = omg1(ip3,jp0,kp1) + g2*coef
+ omg2(ip3,jp0,kp1) = omg2(ip3,jp0,kp1) + g3*coef
+ omg3(ip3,jp0,kp1) = omg3(ip3,jp0,kp1) + g4*coef
+
+ coef=a3*b0*c2
+ omg1(ip3,jp0,kp2) = omg1(ip3,jp0,kp2) + g2*coef
+ omg2(ip3,jp0,kp2) = omg2(ip3,jp0,kp2) + g3*coef
+ omg3(ip3,jp0,kp2) = omg3(ip3,jp0,kp2) + g4*coef
+
+ coef=a3*b0*c3
+ omg1(ip3,jp0,kp3) = omg1(ip3,jp0,kp3) + g2*coef
+ omg2(ip3,jp0,kp3) = omg2(ip3,jp0,kp3) + g3*coef
+ omg3(ip3,jp0,kp3) = omg3(ip3,jp0,kp3) + g4*coef
+
+ coef=a3*b1*c0
+ omg1(ip3,jp1,kp0) = omg1(ip3,jp1,kp0) + g2*coef
+ omg2(ip3,jp1,kp0) = omg2(ip3,jp1,kp0) + g3*coef
+ omg3(ip3,jp1,kp0) = omg3(ip3,jp1,kp0) + g4*coef
+
+ coef=a3*b1*c1
+ omg1(ip3,jp1,kp1) = omg1(ip3,jp1,kp1) + g2*coef
+ omg2(ip3,jp1,kp1) = omg2(ip3,jp1,kp1) + g3*coef
+ omg3(ip3,jp1,kp1) = omg3(ip3,jp1,kp1) + g4*coef
+
+ coef=a3*b1*c2
+ omg1(ip3,jp1,kp2) = omg1(ip3,jp1,kp2) + g2*coef
+ omg2(ip3,jp1,kp2) = omg2(ip3,jp1,kp2) + g3*coef
+ omg3(ip3,jp1,kp2) = omg3(ip3,jp1,kp2) + g4*coef
+
+ coef=a3*b1*c3
+ omg1(ip3,jp1,kp3) = omg1(ip3,jp1,kp3) + g2*coef
+ omg2(ip3,jp1,kp3) = omg2(ip3,jp1,kp3) + g3*coef
+ omg3(ip3,jp1,kp3) = omg3(ip3,jp1,kp3) + g4*coef
+
+ coef=a3*b2*c0
+ omg1(ip3,jp2,kp0) = omg1(ip3,jp2,kp0) + g2*coef
+ omg2(ip3,jp2,kp0) = omg2(ip3,jp2,kp0) + g3*coef
+ omg3(ip3,jp2,kp0) = omg3(ip3,jp2,kp0) + g4*coef
+
+ coef=a3*b2*c1
+ omg1(ip3,jp2,kp1) = omg1(ip3,jp2,kp1) + g2*coef
+ omg2(ip3,jp2,kp1) = omg2(ip3,jp2,kp1) + g3*coef
+ omg3(ip3,jp2,kp1) = omg3(ip3,jp2,kp1) + g4*coef
+
+ coef=a3*b2*c2
+ omg1(ip3,jp2,kp2) = omg1(ip3,jp2,kp2) + g2*coef
+ omg2(ip3,jp2,kp2) = omg2(ip3,jp2,kp2) + g3*coef
+ omg3(ip3,jp2,kp2) = omg3(ip3,jp2,kp2) + g4*coef
+
+ coef=a3*b2*c3
+ omg1(ip3,jp2,kp3) = omg1(ip3,jp2,kp3) + g2*coef
+ omg2(ip3,jp2,kp3) = omg2(ip3,jp2,kp3) + g3*coef
+ omg3(ip3,jp2,kp3) = omg3(ip3,jp2,kp3) + g4*coef
+
+ coef=a3*b3*c0
+ omg1(ip3,jp3,kp0) = omg1(ip3,jp3,kp0) + g2*coef
+ omg2(ip3,jp3,kp0) = omg2(ip3,jp3,kp0) + g3*coef
+ omg3(ip3,jp3,kp0) = omg3(ip3,jp3,kp0) + g4*coef
+
+ coef=a3*b3*c1
+ omg1(ip3,jp3,kp1) = omg1(ip3,jp3,kp1) + g2*coef
+ omg2(ip3,jp3,kp1) = omg2(ip3,jp3,kp1) + g3*coef
+ omg3(ip3,jp3,kp1) = omg3(ip3,jp3,kp1) + g4*coef
+
+ coef=a3*b3*c2
+ omg1(ip3,jp3,kp2) = omg1(ip3,jp3,kp2) + g2*coef
+ omg2(ip3,jp3,kp2) = omg2(ip3,jp3,kp2) + g3*coef
+ omg3(ip3,jp3,kp2) = omg3(ip3,jp3,kp2) + g4*coef
+
+ coef=a3*b3*c3
+ omg1(ip3,jp3,kp3) = omg1(ip3,jp3,kp3) + g2*coef
+ omg2(ip3,jp3,kp3) = omg2(ip3,jp3,kp3) + g3*coef
+ omg3(ip3,jp3,kp3) = omg3(ip3,jp3,kp3) + g4*coef
+
+ end DO
+
+end SUBROUTINE remesh_om
diff --git a/CodesEnVrac/CodeGH/src-THI/remesh_rho.f b/CodesEnVrac/CodeGH/src-THI/remesh_rho.f
new file mode 100644
index 0000000000000000000000000000000000000000..89fa19ae2ac4237955f471a35b3d50e4de49601e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remesh_rho.f
@@ -0,0 +1,379 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE remesh_rho(npart,phip,
+ 1 xp2,yp2,zp2)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp2(*),yp2(*),zp2(*)
+ dimension phip(*)
+
+
+ do 10 i=1,nx2
+ do 10 j=1,ny2
+ do 10 k=1,nz2
+ ug(i,j,k)=0.
+10 continue
+
+ dy2=dx2
+ dz2=dx2
+
+ dxinv=1./(dx2)
+ dyinv=dxinv
+ dzinv=dxinv
+
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=0.
+ y0=0.
+ z0=0.
+
+ vol=1.
+
+ DO 20 n = 1,npart
+
+ g1 = phip(n)/vol
+
+ x = xp2(n)
+ y = yp2(n)
+ z = zp2(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+C Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dy2-y0)*dyinv
+ zz1 = (z - float(kp1)*dz2-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+C
+C on repositionne les points de grille par periodicite
+! entre 0 et npx-1, puis on numerote de 1 a npx
+C
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+
+ jp1=mod(jp1+ny2,ny2) +1
+ jp0=mod(jp0+ny2,ny2) +1
+ jp2=mod(jp2+ny2,ny2) +1
+ jp3=mod(jp3+ny2,ny2) +1
+
+ kp1=mod(kp1+nz2,nz2) +1
+ kp0=mod(kp0+nz2,nz2) +1
+ kp2=mod(kp2+nz2,nz2) +1
+ kp3=mod(kp3+nz2,nz2) +1
+
+C The M'4 scheme
+C
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ coef=a0*b0*c0
+ ug(ip0,jp0,kp0) = ug(ip0,jp0,kp0) + g1*coef
+
+ coef=a0*b0*c1
+ ug(ip0,jp0,kp1) = ug(ip0,jp0,kp1) + g1*coef
+
+ coef=a0*b0*c2
+ ug(ip0,jp0,kp2) = ug(ip0,jp0,kp2) + g1*coef
+
+ coef=a0*b0*c3
+ ug(ip0,jp0,kp3) = ug(ip0,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b1*c0
+ ug(ip0,jp1,kp0) = ug(ip0,jp1,kp0) + g1*coef
+
+ coef=a0*b1*c1
+ ug(ip0,jp1,kp1) = ug(ip0,jp1,kp1) + g1*coef
+
+ coef=a0*b1*c2
+ ug(ip0,jp1,kp2) = ug(ip0,jp1,kp2) + g1*coef
+
+ coef=a0*b1*c3
+ ug(ip0,jp1,kp3) = ug(ip0,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b2*c0
+ ug(ip0,jp2,kp0) = ug(ip0,jp2,kp0) + g1*coef
+
+ coef=a0*b2*c1
+ ug(ip0,jp2,kp1) = ug(ip0,jp2,kp1) + g1*coef
+
+ coef=a0*b2*c2
+ ug(ip0,jp2,kp2) = ug(ip0,jp2,kp2) + g1*coef
+
+
+ coef=a0*b2*c3
+ ug(ip0,jp2,kp3) = ug(ip0,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a0*b3*c0
+ ug(ip0,jp3,kp0) = ug(ip0,jp3,kp0) + g1*coef
+
+ coef=a0*b3*c1
+ ug(ip0,jp3,kp1) = ug(ip0,jp3,kp1) + g1*coef
+
+ coef=a0*b3*c2
+ ug(ip0,jp3,kp2) = ug(ip0,jp3,kp2) + g1*coef
+
+ coef=a0*b3*c3
+ ug(ip0,jp3,kp3) = ug(ip0,jp3,kp3) + g1*coef
+
+ccc
+ coef=a1*b0*c0
+ ug(ip1,jp0,kp0) = ug(ip1,jp0,kp0) + g1*coef
+
+ coef=a1*b0*c1
+ ug(ip1,jp0,kp1) = ug(ip1,jp0,kp1) + g1*coef
+
+ coef=a1*b0*c2
+ ug(ip1,jp0,kp2) = ug(ip1,jp0,kp2) + g1*coef
+
+ coef=a1*b0*c3
+ ug(ip1,jp0,kp3) = ug(ip1,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b1*c0
+ ug(ip1,jp1,kp0) = ug(ip1,jp1,kp0) + g1*coef
+
+ coef=a1*b1*c1
+ ug(ip1,jp1,kp1) = ug(ip1,jp1,kp1) + g1*coef
+
+ coef=a1*b1*c2
+ ug(ip1,jp1,kp2) = ug(ip1,jp1,kp2) + g1*coef
+
+ coef=a1*b1*c3
+ ug(ip1,jp1,kp3) = ug(ip1,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b2*c0
+ ug(ip1,jp2,kp0) = ug(ip1,jp2,kp0) + g1*coef
+
+ coef=a1*b2*c1
+ ug(ip1,jp2,kp1) = ug(ip1,jp2,kp1) + g1*coef
+
+ coef=a1*b2*c2
+ ug(ip1,jp2,kp2) = ug(ip1,jp2,kp2) + g1*coef
+
+ coef=a1*b2*c3
+ ug(ip1,jp2,kp3) = ug(ip1,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a1*b3*c0
+ ug(ip1,jp3,kp0) = ug(ip1,jp3,kp0) + g1*coef
+
+ coef=a1*b3*c1
+ ug(ip1,jp3,kp1) = ug(ip1,jp3,kp1) + g1*coef
+
+ coef=a1*b3*c2
+ ug(ip1,jp3,kp2) = ug(ip1,jp3,kp2) + g1*coef
+
+ coef=a1*b3*c3
+ ug(ip1,jp3,kp3) = ug(ip1,jp3,kp3) + g1*coef
+
+ccc
+ coef=a2*b0*c0
+ ug(ip2,jp0,kp0) = ug(ip2,jp0,kp0) + g1*coef
+
+ coef=a2*b0*c1
+ ug(ip2,jp0,kp1) = ug(ip2,jp0,kp1) + g1*coef
+
+ coef=a2*b0*c2
+ ug(ip2,jp0,kp2) = ug(ip2,jp0,kp2) + g1*coef
+
+ coef=a2*b0*c3
+ ug(ip2,jp0,kp3) = ug(ip2,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b1*c0
+ ug(ip2,jp1,kp0) = ug(ip2,jp1,kp0) + g1*coef
+
+ coef=a2*b1*c1
+ ug(ip2,jp1,kp1) = ug(ip2,jp1,kp1) + g1*coef
+
+ coef=a2*b1*c2
+ ug(ip2,jp1,kp2) = ug(ip2,jp1,kp2) + g1*coef
+
+ coef=a2*b1*c3
+ ug(ip2,jp1,kp3) = ug(ip2,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b2*c0
+ ug(ip2,jp2,kp0) = ug(ip2,jp2,kp0) + g1*coef
+
+ coef=a2*b2*c1
+ ug(ip2,jp2,kp1) = ug(ip2,jp2,kp1) + g1*coef
+
+ coef=a2*b2*c2
+ ug(ip2,jp2,kp2) = ug(ip2,jp2,kp2) + g1*coef
+
+ coef=a2*b2*c3
+ ug(ip2,jp2,kp3) = ug(ip2,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a2*b3*c0
+ ug(ip2,jp3,kp0) = ug(ip2,jp3,kp0) + g1*coef
+
+ coef=a2*b3*c1
+ ug(ip2,jp3,kp1) = ug(ip2,jp3,kp1) + g1*coef
+
+ coef=a2*b3*c2
+ ug(ip2,jp3,kp2) = ug(ip2,jp3,kp2) + g1*coef
+
+ coef=a2*b3*c3
+ ug(ip2,jp3,kp3) = ug(ip2,jp3,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b0*c0
+ ug(ip3,jp0,kp0) = ug(ip3,jp0,kp0) + g1*coef
+
+ coef=a3*b0*c1
+ ug(ip3,jp0,kp1) = ug(ip3,jp0,kp1) + g1*coef
+
+ coef=a3*b0*c2
+ ug(ip3,jp0,kp2) = ug(ip3,jp0,kp2) + g1*coef
+
+ coef=a3*b0*c3
+ ug(ip3,jp0,kp3) = ug(ip3,jp0,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b1*c0
+ ug(ip3,jp1,kp0) = ug(ip3,jp1,kp0) + g1*coef
+
+ coef=a3*b1*c1
+ ug(ip3,jp1,kp1) = ug(ip3,jp1,kp1) + g1*coef
+
+ coef=a3*b1*c2
+ ug(ip3,jp1,kp2) = ug(ip3,jp1,kp2) + g1*coef
+
+ coef=a3*b1*c3
+ ug(ip3,jp1,kp3) = ug(ip3,jp1,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b2*c0
+ ug(ip3,jp2,kp0) = ug(ip3,jp2,kp0) + g1*coef
+
+ coef=a3*b2*c1
+ ug(ip3,jp2,kp1) = ug(ip3,jp2,kp1) + g1*coef
+
+ coef=a3*b2*c2
+ ug(ip3,jp2,kp2) = ug(ip3,jp2,kp2) + g1*coef
+
+ coef=a3*b2*c3
+ ug(ip3,jp2,kp3) = ug(ip3,jp2,kp3) + g1*coef
+
+ccc
+
+ coef=a3*b3*c0
+ ug(ip3,jp3,kp0) = ug(ip3,jp3,kp0) + g1*coef
+
+ coef=a3*b3*c1
+ ug(ip3,jp3,kp1) = ug(ip3,jp3,kp1) + g1*coef
+
+ coef=a3*b3*c2
+ ug(ip3,jp3,kp2) = ug(ip3,jp3,kp2) + g1*coef
+
+ coef=a3*b3*c3
+ ug(ip3,jp3,kp3) = ug(ip3,jp3,kp3) + g1*coef
+
+ccc
+
+20 CONTINUE
+
+! goto 1111
+
+ npart=0
+
+ do k=1,nz2
+ z=z0+(k-1)*dz2
+ do j=1,ny2
+ y=y0+(j-1)*dy2
+ do i=1,nx2
+ x=x0+(i-1)*dx2
+ strength=abs(ug(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ xp2(npart)=x
+ yp2(npart)=y
+ zp2(npart)=z
+ phip(npart)=ug(i,j,k)*vol
+ endif
+ enddo
+ enddo
+ enddo
+
+1111 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshx.f b/CodesEnVrac/CodeGH/src-THI/remeshx.f
new file mode 100644
index 0000000000000000000000000000000000000000..7c8d24d8fb4f71afb31986a32d54fd4100174733
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshx.f
@@ -0,0 +1,75 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+ ug(ip3,jj,kk) = ug(ip3,jj,kk) + g1*a3
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshx_m6.f b/CodesEnVrac/CodeGH/src-THI/remeshx_m6.f
new file mode 100644
index 0000000000000000000000000000000000000000..e8f62fc01521814b0138cdbf6ba12b0b025183ca
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshx_m6.f
@@ -0,0 +1,83 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+ ip5 = ip1 + 3
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=-xx1+1.
+ xx3=xx1+2.
+ xx4=-xx1+2.
+ xx5=-xx1+3.
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ ip5=mod(ip5+nx2,nx2) +1
+c
+c M'6
+c
+ a0 =(xx0-1.)*(xx0-2.)*(25.*xx0**3-114.*xx0**2+153.*xx0-48.)/24.
+ a1 =-(xx1-1.)*(25.*xx1**4-38.*xx1**3-3.*xx1**2+12.*xx1+12)/12.
+ a2 =-(xx2-1.)*(25.*xx2**4-38.*xx2**3-3.*xx2**2+12.*xx2+12)/12.
+ a3 =-(xx3-2)*(5.*xx3-8.)*(xx3-3.)**3/24.
+ a4 =(xx4-1.)*(xx4-2.)*(25.*xx4**3-114.*xx4**2+153.*xx4-48.)/24.
+ a5 =-(xx5-2)*(5.*xx5-8.)*(xx5-3.)**3/24.
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+ ug(ip3,jj,kk) = ug(ip3,jj,kk) + g1*a3
+ ug(ip4,jj,kk) = ug(ip4,jj,kk) + g1*a4
+ ug(ip5,jj,kk) = ug(ip5,jj,kk) + g1*a5
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshx_tag.f b/CodesEnVrac/CodeGH/src-THI/remeshx_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..ac61cf49c172c11a2123450998ec5f9b4eba81a4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshx_tag.f
@@ -0,0 +1,76 @@
+ subroutine remeshx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag-1,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+xx1*u1-yy1*u2
+ ug(ip3,jj,kk)=ug(ip3,jj,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(ip4,jj,kk)=ug(ip4,jj,kk)+b2*u2
+
+ else
+! case (c') and (d')
+c
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+b2*u2
+
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshy.f b/CodesEnVrac/CodeGH/src-THI/remeshy.f
new file mode 100644
index 0000000000000000000000000000000000000000..1242e5467c31318c8ad38bb9533ffa4d5dd62321
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshy.f
@@ -0,0 +1,61 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+ ug(jj,ip3,kk) = ug(jj,ip3,kk) + g1*a3
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshy_m6.f b/CodesEnVrac/CodeGH/src-THI/remeshy_m6.f
new file mode 100644
index 0000000000000000000000000000000000000000..c88cc315152ba65dab90c7f28d987b0cfc138501
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshy_m6.f
@@ -0,0 +1,83 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+ ip5 = ip1 + 3
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=-xx1+1.
+ xx3=xx1+2.
+ xx4=-xx1+2.
+ xx5=-xx1+3.
+
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ ip5=mod(ip5+nx2,nx2) +1
+c
+c M'6
+c
+ a0 =(xx0-1.)*(xx0-2.)*(25.*xx0**3-114.*xx0**2+153.*xx0-48.)/24.
+ a1 =-(xx1-1.)*(25.*xx1**4-38.*xx1**3-3.*xx1**2+12.*xx1+12)/12.
+ a2 =-(xx2-1.)*(25.*xx2**4-38.*xx2**3-3.*xx2**2+12.*xx2+12)/12.
+ a3 =-(xx3-2)*(5.*xx3-8.)*(xx3-3.)**3/24.
+ a4 =(xx4-1.)*(xx4-2.)*(25.*xx4**3-114.*xx4**2+153.*xx4-48.)/24.
+ a5 =-(xx5-2)*(5.*xx5-8.)*(xx5-3.)**3/24.
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+ ug(jj,ip3,kk) = ug(jj,ip3,kk) + g1*a3
+ ug(jj,ip4,kk) = ug(jj,ip4,kk) + g1*a4
+ ug(jj,ip5,kk) = ug(jj,ip5,kk) + g1*a5
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshy_tag.f b/CodesEnVrac/CodeGH/src-THI/remeshy_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..48ac7b5179b500118a62a08a47fd046a3f0d5cd7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshy_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+xx1*u1-yy1*u2
+ ug(jj,ip3,kk)=ug(jj,ip3,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(jj,ip4,kk)=ug(jj,ip4,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshz.f b/CodesEnVrac/CodeGH/src-THI/remeshz.f
new file mode 100644
index 0000000000000000000000000000000000000000..96b9ec719964a0844473fa919187f07db7197161
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshz.f
@@ -0,0 +1,62 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+! remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 + 2
+
+! print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ xx3=2.-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+
+c
+c left-M'4:
+c
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+ ug(jj,kk,ip3) = ug(jj,kk,ip3) + g1*a3
+
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshz_m6.f b/CodesEnVrac/CodeGH/src-THI/remeshz_m6.f
new file mode 100644
index 0000000000000000000000000000000000000000..f3461757ebf4e8225b9911ffe9e58a724226e211
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshz_m6.f
@@ -0,0 +1,81 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+ ip3 = ip1 - 2
+ ip4 = ip1 + 2
+ ip5 = ip1 + 3
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1.
+ xx2=-xx1+1.
+ xx3=xx1+2.
+ xx4=-xx1+2.
+ xx5=-xx1+3.
+
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ ip5=mod(ip5+nx2,nx2) +1
+c
+c M'6
+c
+ a0 =(xx0-1.)*(xx0-2.)*(25.*xx0**3-114.*xx0**2+153.*xx0-48.)/24.
+ a1 =-(xx1-1.)*(25.*xx1**4-38.*xx1**3-3.*xx1**2+12.*xx1+12)/12.
+ a2 =-(xx2-1.)*(25.*xx2**4-38.*xx2**3-3.*xx2**2+12.*xx2+12)/12.
+ a3 =-(xx3-2)*(5.*xx3-8.)*(xx3-3.)**3/24.
+ a4 =(xx4-1.)*(xx4-2.)*(25.*xx4**3-114.*xx4**2+153.*xx4-48.)/24.
+ a5 =-(xx5-2)*(5.*xx5-8.)*(xx5-3.)**3/24.
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+ ug(jj,kk,ip3) = ug(jj,kk,ip3) + g1*a3
+ ug(jj,kk,ip4) = ug(jj,kk,ip4) + g1*a4
+ ug(jj,kk,ip5) = ug(jj,kk,ip5) + g1*a5
+
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/remeshz_tag.f b/CodesEnVrac/CodeGH/src-THI/remeshz_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..af3a92781f2dbd229ab78d92dea3e214ed6bdb5f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/remeshz_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshz_tag(ntag,itag,itype,icfl,kk,jj)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+! case (c) and (d)
+c
+! if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+xx1*u1-yy1*u2
+ ug(kk,jj,ip3)=ug(kk,jj,ip3)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(kk,jj,ip4)=ug(kk,jj,ip4)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+! else
+! case (d)
+! endif
+ else
+! case (c') and (d')
+c
+! if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+(1.-a0)*u1+(1.-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+b2*u2
+! print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+! else
+! case (d')
+! endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-THI/sfftw3d.f90 b/CodesEnVrac/CodeGH/src-THI/sfftw3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ebc9123955a2dfdd4d9e79b434ff982b8558fbb8
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/sfftw3d.f90
@@ -0,0 +1,142 @@
+subroutine fftw3d(r,c,nx,ny,nz,nxs2,nys2,nzs2,wk,irc)
+
+ ! Ce programme calcul la transformee de fourier rapide
+ !----------------------------------------------------------------------
+ ! TRANSFORMATION DE FOURIER REELLE<--->COMPLEXE TRI-DIMENSIONNELLE
+ ! X : VECTEUR REEL DE DIMENSION (nx,ny,nz)
+ ! C : VECTEUR COMPLEXE DE DIMENSION (0:nx/2,-ny/2+1:ny/2,-nz/2+1:nz/2)
+ ! WK : Vecteur de travail pour les fftw de dimension (0:nx/2,0:ny-1,0:nz-1)
+ ! IRC : =0: REELLE ---> COMPLEXE (X-->C) Directe
+ ! <>0: COMPLEXE ---> REELLE (C-->X) inverse
+ !
+ ! REMARQUE:
+ ! CALCULE LA TRANSFORMATION SUIVANTE:
+ !
+ ! X(J,K,L) J(1..nx),K(1..ny),L(1..Nz) <---> C(J,K,L) J=0..nx/2 K=-ny/2+1,...,ny/2,
+ ! L=-nz/2+1,...,nz/2
+ !
+ !----------------------------------------------------------------------
+ !
+ ! Declaration pour utiliser les routines fftw
+ !
+ ! This file contains PARAMETER statements for various constants
+ ! that can be passed to FFTW routines. You should include
+ ! this file in any FORTRAN program that calls the fftw_f77
+ ! routines (either directly or with an #include statement
+ ! if you use the C preprocessor).
+ !
+
+ include '/opt/Softs/fftw/fftw-3.2.2-intel/include/fftw3.f'
+
+ ! INTEGER FFTW_FORWARD,FFTW_BACKWARD
+ ! PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+ !
+ ! INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+ ! PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+ !
+ ! INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+ ! PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+ ! INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+ ! PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
+
+ integer plan,nx,ny,nz,nxs2,nys2,nzs2,irc,i,j,k
+
+ complex c,wk
+ dimension c(0:nxs2,1-nys2:nys2,1-nzs2:nzs2),wk(nxs2+1,ny,nz)
+
+ real r
+ dimension r(nx,ny,nz)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=cmplx(0.0,0.0)
+ enddo
+ enddo
+ enddo
+
+ plan=0
+ if (irc.eq.0) then
+
+ call sfftw_plan_dft_r2c_3d(plan,nx,ny,nz,r,wk,FFTW_ESTIMATE)
+ call sfftw_execute(plan)
+ call sfftw_destroy_plan(plan)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=wk(i,j,k)/nx/ny/nz
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-1)=wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-1)=wk(i,j+nys2+1,k)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-nzs2)=wk(i,j,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-nzs2)=wk(i,j+nys2+1,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+ else
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k)=c(i-1,j-1,k-1)
+ enddo
+ enddo
+ enddo
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k)=c(i-1,j-nys2,k-1)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k+nzs2+1)=c(i-1,j-1,k-nzs2)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k+nzs2+1)=c(i-1,j-nys2,k-nzs2)
+ enddo
+ enddo
+ enddo
+
+ call sfftw_plan_dft_c2r_3d(plan,nx,ny,nz,wk,r,FFTW_ESTIMATE)
+ call sfftw_execute(plan)
+ call sfftw_destroy_plan(plan)
+
+ endif
+ return
+end subroutine fftw3d
diff --git a/CodesEnVrac/CodeGH/src-THI/stretch.f b/CodesEnVrac/CodeGH/src-THI/stretch.f
new file mode 100644
index 0000000000000000000000000000000000000000..7173c5cda497f93b0098b5bf268236a620d00cea
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/stretch.f
@@ -0,0 +1,100 @@
+ subroutine stretch
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dy1=dx1
+ dz1=dx1
+
+ dxinv=1./(12.*dx1)
+ dyinv=1./(12.*dy1)
+ dzinv=1./(12.*dz1)
+
+ do k=1,nz1
+ kt=mod(k+nz1,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ ktt=mod(k+1+nz1,nz1)+1
+ kbb=mod(k-3+nz1,nz1)+1
+cc
+ do j=1,ny1
+ jt=mod(j+ny1,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ jtt=mod(j+1+ny1,ny1)+1
+ jbb=mod(j-3+ny1,ny1)+1
+cc
+ do i=1,nx1
+ it=mod(i+nx1,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ itt=mod(i+1+nx1,nx1)+1
+ ibb=mod(i-3+nx1,nx1)+1
+
+c
+ aux1=
+omg1(itt,j,k)*vxg(itt,j,k)
++8.*(omg1(ib,j,k)*vxg(ib,j,k)
+-omg1(it,j,k)*vxg(it,j,k))
+-omg1(ibb,j,k)*vxg(ibb,j,k)
+
+
+ aux2=
+omg2(i,jtt,k)*vxg(i,jtt,k)
++8.*(omg2(i,jb,k)*vxg(i,jb,k)
+-omg2(i,jt,k)*vxg(i,jt,k))
+-omg2(i,jbb,k)*vxg(i,jbb,k)
+
+ aux3=
+omg3(i,j,ktt)*vxg(i,j,ktt)
++8.*(omg3(i,j,kb)*vxg(i,j,kb)
+-omg3(i,j,kt)*vxg(i,j,kt))
+-omg3(i,j,kbb)*vxg(i,j,kbb)
+
+strg1(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+
+ aux1=
+omg1(itt,j,k)*vyg(itt,j,k)
++8.*(omg1(ib,j,k)*vyg(ib,j,k)
+-omg1(it,j,k)*vyg(it,j,k))
+-omg1(ibb,j,k)*vyg(ibb,j,k)
+
+ aux2=
+omg2(i,jtt,k)*vyg(i,jtt,k)
++8.*(omg2(i,jb,k)*vyg(i,jb,k)
+-omg2(i,jt,k)*vyg(i,jt,k))
+-omg2(i,jbb,k)*vyg(i,jbb,k)
+
+ aux3=
+omg3(i,j,ktt)*vyg(i,j,ktt)
++8.*(omg3(i,j,kb)*vyg(i,j,kb)
+-omg3(i,j,kt)*vyg(i,j,kt))
+-omg3(i,j,kbb)*vyg(i,j,kbb)
+
+ strg2(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+
+ aux1=
+omg1(itt,j,k)*vzg(itt,j,k)
++8.*(omg1(ib,j,k)*vzg(ib,j,k)
+-omg1(it,j,k)*vzg(it,j,k))
+-omg1(ibb,j,k)*vzg(ibb,j,k)
+
+ aux2=
+omg2(i,jtt,k)*vzg(i,jtt,k)
++8.*(omg2(i,jb,k)*vzg(i,jb,k)
+-omg2(i,jt,k)*vzg(i,jt,k))
+-omg2(i,jbb,k)*vzg(i,jbb,k)
+
+ aux3=
+omg3(i,j,ktt)*vzg(i,j,ktt)
++8.*(omg3(i,j,kb)*vzg(i,j,kb)
+-omg3(i,j,kt)*vzg(i,j,kt))
+-omg3(i,j,kbb)*vzg(i,j,kbb)
+
+ strg3(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+
+ enddo
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/tag_particles.f b/CodesEnVrac/CodeGH/src-THI/tag_particles.f
new file mode 100644
index 0000000000000000000000000000000000000000..b2a5d0fff5c07d3d06fdf3353653ee18df555295
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/tag_particles.f
@@ -0,0 +1,181 @@
+ subroutine tag_particles(npart,npart_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ include 'param.i'
+ include 'param.h'
+
+ common/remesh/xp(npg),xp1(npg),up(npg),vx(npg)
+
+ integer icfl(*),itype(*),itype_aux(*),itag(*)
+ dimension xp_aux(*),up_aux(*),vx_aux(*)
+
+ integer ntype(npg),ncfl(npg),npart_bl(npg),i_nbl(npg)
+ dimension amin_lambda(npg)
+
+
+c ntype(nbl) : type de bloc (1=centre ou 0=left) pour choix de la formule
+c remaillage
+c itype(npart) : idem pour les particules de ces blocks
+c ncfl(nbl)=cfl-nint ou cfl-int selon le type
+c icfl(npart) : idem pour particules de cs blocks
+c xp_aux(npart_aux): particles inside the blocks, for plain remeshing
+c itype_aux(npart_aux) : type de block pour ces particules
+c ntag: number of tagged particles, for special remeshing
+c itag(ntag): pointer for tagged particles
+c i_nbl(nbl) indice de la derniere particule du bloc nbl
+
+c cfl=delt/dx
+
+ x0=xmin
+
+
+ m=np_bl+1
+ nblock=nx/(m)
+ dx_bl=float(m)*dx
+ dx_bl_inv=1./dx_bl
+
+c on range les partucles par block
+c et on calcule lambda moyen pour chaque block
+
+ do nbl=1,nblock
+ amin_lambda(nbl)=111.
+ npart_bl(nbl)=0
+ i_nbl(nbl)=0
+ enddo
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(i)*cfl)
+ npart_bl(nbl)=npart_bl(nbl)+1
+ i_nbl(nbl)=i
+ enddo
+
+c on ajoute la particule a droite du bloc (si elle existe) pour calculer
+c le amin_lambda, pour eviter pbms a l'interface entre blocs de meme type
+c (a corriger: pour l'instant je ne regarde pas le dernier bloc avec xp(1)
+
+ do nbl=1,nblock-1
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((ii.lt.npart).and.(xp(ii+1).lt.xp(ii)+1.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+ enddo
+
+c le dernier bloc (a la main ..)
+
+ nbl=nblock
+ if (i_nbl(nbl).ne.0) then
+ if ((xp(npart).ge.xmax-1.5*dx).and.(xp(1).lt.xmin+0.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(1)*cfl)
+ endif
+ endif
+
+
+c et on en deduit type de block (1=centre vs 0=left) et l'indice du bloc
+
+
+ do nbl=1,nblock
+ if (amin_lambda(nbl).lt.nint(amin_lambda(nbl))) then
+ ntype(nbl)=1
+ ncfl(nbl)=nint(amin_lambda(nbl))
+ else
+ ntype(nbl)=0
+ ncfl(nbl)=int(amin_lambda(nbl))
+ if (amin_lambda(nbl).lt.0) ncfl(nbl)=int(amin_lambda(nbl))-1
+ endif
+
+c print*,'nbl et type',nbl, ntype(nbl),amin_lambda(nbl)
+ enddo
+c
+c on affecte le type et l'indice cfl du bloc sur ses particules
+
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ itype(i)=ntype(nbl)
+ icfl(i)=ncfl(nbl)
+c print*,'nbl et type',nbl,i, itype(i),icfl(i)
+ enddo
+
+
+c on tagge les particules entre les blocs successifs non vides qui:
+c sont de type et indice cfl differents
+c (cases b,c,b',c' du papier)
+
+ ntag=0
+ npart_aux=0
+ j=2
+ jc=0
+ do i=2,npart-1
+ j=j+jc
+ if (j.ge.npart) go to 111
+ jj=j+1
+c print*,j,icfl(j),icfl(jj),itype(j),itype(jj)
+ if ((icfl(j).ne.icfl(jj)).and.(itype(j).ne.itype(jj))
+ 1 .and.(xp(jj).le.xp(j)+1.5*dx)) then
+ ntag=ntag+1
+ itag(ntag)=j
+ ntag=ntag+1
+ itag(ntag)=j+1
+c print*,' **** TAGGED ',j,xp(j),itype(j),icfl(j),vx(j)*delt/dx,
+c 1 nint(vx(j)*delt/dx)
+c print*,' **** TAGGED ',jj,xp(jj),itype(jj),icfl(jj),vx(jj)*delt/dx,
+c 1 nint(vx(jj)*delt/dx)
+ jc=2
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(j)
+ up_aux(npart_aux)=up(j)
+ vx_aux(npart_aux)=vx(j)
+ itype_aux(npart_aux)=itype(j)
+c print*,'REGULAR',npart_aux,xp_aux(npart_aux),up_aux(npart_aux)
+c 1 ,vx_aux(j)*delt/dx,icfl(j)
+ jc=1
+ endif
+ enddo
+
+111 continue
+
+c on regarde a part la premiere et la derniere particule
+c (je ne sais pas faire autrement pour l'instant)
+
+ if (npart.ge.1) then
+
+ if ((icfl(1).ne.icfl(npart)).and.(itype(1).ne.itype(npart))
+ 1 .and.(xp(npart).ge.xp(1)+(float(nx)-1.5)*dx)
+ 1 .and.(itag(ntag).ne.npart)) then
+c 1 ) then
+ ntag=ntag+1
+ itag(ntag)=npart
+ ntag=ntag+1
+ itag(ntag)=1
+c print*,' TAGGED ',j,xp(j),icfl(j)
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(1)
+ up_aux(npart_aux)=up(1)
+ vx_aux(npart_aux)=vx(1)
+ itype_aux(npart_aux)=itype(1)
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ if (npart.gt.1) then
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(npart)
+ up_aux(npart_aux)=up(npart)
+ vx_aux(npart_aux)=vx(npart)
+ itype_aux(npart_aux)=itype(npart)
+ endif
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ endif
+
+ endif
+
+
+
+c if (ntag.ne.0) print*,'npart,NTAG, NPART_AUX = ',npart,ntag,npart_aux
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/velox.f b/CodesEnVrac/CodeGH/src-THI/velox.f
new file mode 100644
index 0000000000000000000000000000000000000000..d3e208211a1d74e441e2c3ad08bc718906dfe588
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/velox.f
@@ -0,0 +1,124 @@
+ subroutine velox(vmax,delt)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension aux3(npgx,npgy,npgz),
+ 1 aux1(npgx,npgy,npgz),aux2(npgx,npgy,npgz)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+
+ pi=3.1415926
+
+ dxinv=1./(2.*dx1)
+
+c calucl de fonction courants 3d
+
+ nxb=nx1/2
+ nyb=ny1/2
+ nzb=nz1/2
+
+ call fftw3d(omg1,cfx,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg2,cfy,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+ call fftw3d(omg3,cfz,nx1,ny1,nz1,nxb,nyb,nzb,wk,0)
+
+c coeff de normalisation pour laplacien en spectral
+
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nzb,nzb
+ rk=float(k)*ak
+ do 10 j=1-nyb,nyb
+ rj=float(j)*aj
+ do 10 i=0,nxb
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+ if (r2.ne.0.) then
+c
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ endif
+10 continue
+
+
+ call fftw3d(aux1,cux,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+ call fftw3d(aux2,cuy,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+ call fftw3d(aux3,cuz,nx1,ny1,nz1,nxb,nyb,nzb,wk,1)
+
+c calcul de du/dt + (u.grad)u stocke dans strg
+c pour terme barotrope (dans stretch_freeb)
+c (si pas boussinesq)
+c (cf /home/ghcottet/FS/2D/FFT velox_fft et bar)
+c et update des vitesses
+
+ vxmax=0.
+ vymax=0.
+ vzmax=0.
+ do k=1,nz1
+ do j=1,ny1
+ do i=1,nx1
+ strg1(i,j,k)=(-aux1(i,j,k)-vxg(i,j,k))/delt
+ strg2(i,j,k)=(-aux2(i,j,k)-vyg(i,j,k))/delt
+ strg3(i,j,k)=(-aux3(i,j,k)-vzg(i,j,k))/delt
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ vxmax=amax1(vxmax,abs(vxg(i,j,k)))
+ vymax=amax1(vymax,abs(vyg(i,j,k)))
+ vzmax=amax1(vzmax,abs(vzg(i,j,k)))
+ enddo
+ enddo
+ enddo
+ print*,' VXMAX sur grille ',vxmax,vymax,vzmax
+ vmax=amax1(vxmax,vymax)
+ vmax=amax1(vmax,vzmax)
+
+ do k=1,nz1
+ kt=mod(k+nz1,nz1)+1
+ kb=mod(k-2+nz1,nz1)+1
+ do j=1,ny1
+ jt=mod(j+ny1,ny1)+1
+ jb=mod(j-2+ny1,ny1)+1
+ do i=1,nx1
+ it=mod(i+nx1,nx1)+1
+ ib=mod(i-2+nx1,nx1)+1
+ strg1(i,j,k)=strg1(i,j,k)+vxg(i,j,k)*(vxg(it,j,k)-vxg(ib,j,k))*dxinv
+ strg1(i,j,k)=strg1(i,j,k)+vyg(i,j,k)*(vxg(i,jt,k)-vxg(i,jb,k))*dxinv
+ strg1(i,j,k)=strg1(i,j,k)+vzg(i,j,k)*(vxg(i,j,kt)-vxg(i,j,kb))*dxinv
+ strg2(i,j,k)=strg2(i,j,k)+vxg(i,j,k)*(vyg(it,j,k)-vyg(ib,j,k))*dxinv
+ strg2(i,j,k)=strg2(i,j,k)+vyg(i,j,k)*(vyg(i,jt,k)-vyg(i,jb,k))*dxinv
+ strg2(i,j,k)=strg2(i,j,k)+vzg(i,j,k)*(vyg(i,j,kt)-vyg(i,j,kb))*dxinv
+ strg3(i,j,k)=strg3(i,j,k)+vxg(i,j,k)*(vzg(it,j,k)-vzg(ib,j,k))*dxinv
+ strg3(i,j,k)=strg3(i,j,k)+vyg(i,j,k)*(vzg(i,jt,k)-vzg(i,jb,k))*dxinv
+ strg3(i,j,k)=strg3(i,j,k)+vzg(i,j,k)*(vzg(i,j,kt)-vzg(i,j,kb))*dxinv
+ enddo
+ enddo
+ enddo
+
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-THI/velox_x.f b/CodesEnVrac/CodeGH/src-THI/velox_x.f
new file mode 100644
index 0000000000000000000000000000000000000000..b87a522b020f4fbb3cd72e2cbd12c61527da472b
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/velox_x.f
@@ -0,0 +1,106 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_x(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g1(npg)
+
+ do 10 i=1,npart
+ g1(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/velox_y.f b/CodesEnVrac/CodeGH/src-THI/velox_y.f
new file mode 100644
index 0000000000000000000000000000000000000000..64e8c6bd6f349bf174643db62fabe2f8625cbcd7
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/velox_y.f
@@ -0,0 +1,104 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_y(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g2(npg)
+
+ do 10 i=1,npart
+ g2(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + gg2(jp1,ip2,kp1)*a2*b1*c1
+ g2(i)= g2(i) + gg2(jp2,ip1,kp1)*a1*b2*c1
+ g2(i)= g2(i) + gg2(jp2,ip2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + gg2(jp1,ip2,kp2)*a2*b1*c2
+ g2(i)= g2(i) + gg2(jp2,ip1,kp2)*a1*b2*c2
+ g2(i)= g2(i) + gg2(jp2,ip2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/velox_z.f b/CodesEnVrac/CodeGH/src-THI/velox_z.f
new file mode 100644
index 0000000000000000000000000000000000000000..40151259fe1e29bffd2e56ae1f75dc1dfa507cba
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/velox_z.f
@@ -0,0 +1,105 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_z(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g3(npg)
+
+
+ do 10 i=1,npart
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip1)*a1*b1*c1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip2)*a2*b1*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip1)*a1*b2*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip2)*a2*b2*c1
+ g3(i)= g3(i) + gg3(jp1,kp2,ip1)*a1*b1*c2
+ g3(i)= g3(i) + gg3(jp1,kp2,ip2)*a2*b1*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip1)*a1*b2*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip2)*a2*b2*c2
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-THI/veloxaux.f b/CodesEnVrac/CodeGH/src-THI/veloxaux.f
new file mode 100644
index 0000000000000000000000000000000000000000..0f64cd1173076ed00193b8005c81f4380e4bda94
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/veloxaux.f
@@ -0,0 +1,159 @@
+ subroutine veloxaux(vmax,dvmax)
+
+c version de veloxaux ou on prend les 32 premiers
+c modes de la vitesse, on padde avec des 0 jusqu'a nx2 (128 ou 256)
+c et on fait fft inverse sur une grille nx2
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ parameter(npg2=npg)
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ dimension aux1(npg2,npg2,npg2),aux2(npg2,npg2,npg2)
+ dimension aux3(npg2,npg2,npg2)
+
+ parameter(npgb2=npg2/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+ complex cvx,cvy,cvz,wk2
+ dimension cvx(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvy(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 cvz(0:npgb2,1-npgb2:npgb2,1-npgb2:npgb2),
+ 1 wk2(npgb2+1,npg2,npg2)
+
+ dx3=(xmax-xmin)/float(nx3)
+
+ goto 113
+c si on veut pas filter ..
+
+ do k=1,nx1
+ do j=1,nx1
+ do i=1,nx1
+ aux1(i,j,k)=-vxg(i,j,k)
+ aux2(i,j,k)=-vyg(i,j,k)
+ aux3(i,j,k)=-vzg(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ go to 112
+
+113 continue
+
+ pi=3.1415926
+
+ nxb2=nx3/2
+ nyb2=nx3/2
+ nzb2=nx3/2
+ nxb2=32
+ nyb2=32
+ nzb2=32
+ nxb=nx1/2
+ nyb=nx1/2
+ nzb=nx1/2
+
+ do 20 k=1-nzb,nzb
+ do 20 j=1-nyb,nyb
+ do 20 i=0,nxb
+ cvx(i,j,k)=0.
+ cvy(i,j,k)=0.
+ cvz(i,j,k)=0.
+20 continue
+
+ do 10 k=1-nzb2,nzb2
+ do 10 j=1-nyb2,nyb2
+ do 10 i=0,nxb2
+ cvx(i,j,k)=cux(i,j,k)
+ cvy(i,j,k)=cuy(i,j,k)
+ cvz(i,j,k)=cuz(i,j,k)
+10 continue
+
+c call fftw3d(aux3,cvz,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+c call fftw3d(aux2,cvy,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+c call fftw3d(aux1,cvx,nx3,nx3,nx3,nxb2,nyb2,nzb2,wk2,1)
+ call fftw3d(aux3,cvz,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+ call fftw3d(aux2,cvy,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+ call fftw3d(aux1,cvx,nx1,nx1,nx1,nxb,nyb,nzb,wk2,1)
+
+c ecriture fhciers grille NX2
+
+112 continue
+
+ umax1=0.
+ umax2=0.
+ umax3=0.
+ dvmax=0.
+ dvxmax=0.
+ dvymax=0.
+ dvzmax=0.
+ do k=1,nx3
+ do j=1,nx3
+ do i=1,nx3
+ psi1(i,j,k)=-aux1(i,j,k)
+ umax1=amax1(umax1,abs(psi1(i,j,k)))
+ psi2(i,j,k)=-aux2(i,j,k)
+ umax2=amax1(umax2,abs(psi2(i,j,k)))
+ psi3(i,j,k)=-aux3(i,j,k)
+ umax3=amax1(umax3,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ do k=1,nx3
+ kt=mod(k,nx3)+1
+ do j=1,nx3
+ jt=mod(j,nx3)+1
+ do i=1,nx3
+ it=mod(i,nx3)+1
+ dvxmax=amax1(dvxmax,abs(psi1(it,j,k)-psi1(i,j,k)))
+ dvymax=amax1(dvymax,abs(psi2(i,jt,k)-psi2(i,j,k)))
+ dvzmax=amax1(dvzmax,abs(psi3(i,j,kt)-psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ dvmax=amax1(dvxmax,dvymax)
+ dvmax=amax1(dvmax,dvzmax)/dx3
+
+ print*,'umax', umax1,umax2,umax3
+ print*,'DVMAXs ',dvxmax/dx3,dvymax/dx3,dvzmax/dx3
+
+ vmax=amax1(umax1,umax2,umax3)
+
+ goto 111
+
+ open(20,file='datavelx',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(20) ((((psi1(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(21,file='datavely',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(21) ((((psi2(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ open(22,file='datavelz',form='unformatted',
+ 1 convert='big_endian',
+ 1 status='unknown')
+ write(22) ((((psi3(i,j,k)),
+ 1 i=1,nx3),j=1,nx3),k=1,nx3)
+ close(20)
+ close(21)
+ close(22)
+
+111 continue
+
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/x_advect.f b/CodesEnVrac/CodeGH/src-THI/x_advect.f
new file mode 100644
index 0000000000000000000000000000000000000000..0f79ca21cbd88d264d575d58c3a5344f048927d0
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/x_advect.f
@@ -0,0 +1,87 @@
+ subroutine x_advect(dt,np_bl,npart,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! routine d'advection en x :
+! parcours des lignes horozontales
+! intilisation de particules
+! calcul des vitesses par RK2
+! tag des particules en focntion des varaitions de cfl
+! push and remesh
+
+! cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+! 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+! initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+222 continue
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np_aux,xp_aux,up_aux,itype_aux,jr,kr)
+ if (ntag.ne.0) call remeshx_tag(ntag,itag,itype,icfl,jr,kr)
+
+! fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/y_advect.f b/CodesEnVrac/CodeGH/src-THI/y_advect.f
new file mode 100644
index 0000000000000000000000000000000000000000..bc8a8519ca2d1385891e9050d0819e70519485a9
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/y_advect.f
@@ -0,0 +1,80 @@
+ subroutine y_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+
+c cfl=dt/dx utilisse pour calculs de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+c on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+c initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np_aux,xp_aux,up_aux,itype_aux,ir,kr)
+ if (ntag.ne.0) call remeshy_tag(ntag,itag,itype,icfl,ir,kr)
+
+c fin de ligne i :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+ print*, ' NTAG apres y advect ', ntag_total
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-THI/z_advect.f b/CodesEnVrac/CodeGH/src-THI/z_advect.f
new file mode 100644
index 0000000000000000000000000000000000000000..38620f9a2e1ff5eae884409aa512650c7053534f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-THI/z_advect.f
@@ -0,0 +1,79 @@
+ subroutine z_advect(dt,np_bl,ntag_total)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+! cf=dt/dx utilise pour calucls de blocs et correction
+ cfl=dt/dx
+
+ ntag_total=0
+
+! on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+! initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+! tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+! evaluation des vitesse pour RK2
+
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ if (xp(ii).lt.xmin) xp(ii)=xp(ii)+xmax-xmin
+ enddo
+ endif
+
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np_aux,xp_aux,up_aux,itype_aux,ir,jr)
+ if (ntag.ne.0) call remeshz_tag(ntag,itag,itype,icfl,ir,jr)
+
+! fin de ligne k :
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, ' NTAG apres z_advect ', ntag_total
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-common/fftw3d.f90 b/CodesEnVrac/CodeGH/src-common/fftw3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..797162e9763b58707f1fb36ce64386d8f4321ac9
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-common/fftw3d.f90
@@ -0,0 +1,147 @@
+subroutine fftw3d(r,c,nx,ny,nz,nxs2,nys2,nzs2,wk,irc)
+
+ ! Ce programme calcul la transformee de fourier rapide
+ !----------------------------------------------------------------------
+ ! TRANSFORMATION DE FOURIER REELLE<--->COMPLEXE TRI-DIMENSIONNELLE
+ ! X : VECTEUR REEL DE DIMENSION (nx,ny,nz)
+ ! C : VECTEUR COMPLEXE DE DIMENSION (0:nx/2,-ny/2+1:ny/2,-nz/2+1:nz/2)
+ ! WK : Vecteur de travail pour les fftw de dimension (0:nx/2,0:ny-1,0:nz-1)
+ ! IRC : =0: REELLE ---> COMPLEXE (X-->C) Directe
+ ! <>0: COMPLEXE ---> REELLE (C-->X) inverse
+ !
+ ! REMARQUE:
+ ! CALCULE LA TRANSFORMATION SUIVANTE:
+ !
+ ! X(J,K,L) J(1..nx),K(1..ny),L(1..Nz) <---> C(J,K,L) J=0..nx/2 K=-ny/2+1,...,ny/2,
+ ! L=-nz/2+1,...,nz/2
+ !
+ !----------------------------------------------------------------------
+ !
+ ! Declaration pour utiliser les routines fftw
+ !
+ ! This file contains PARAMETER statements for various constants
+ ! that can be passed to FFTW routines. You should include
+ ! this file in any FORTRAN program that calls the fftw_f77
+ ! routines (either directly or with an #include statement
+ ! if you use the C preprocessor).
+
+
+ include 'fftw3.f'
+
+ ! INTEGER FFTW_FORWARD,FFTW_BACKWARD
+ ! PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+ !
+ ! INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+ ! PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+ !
+ ! INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+ ! PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+ !
+ ! INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+ ! PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
+ !
+ integer plan,nx,ny,nz,nxs2,nys2,nzs2,irc,i,j,k
+ !
+ complex c,wk
+ dimension c(0:nxs2,1-nys2:nys2,1-nzs2:nzs2),wk(nxs2+1,ny,nz)
+ !
+ real r
+ dimension r(nx,ny,nz)
+ !
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=cmplx(0.0,0.0)
+ enddo
+ enddo
+ enddo
+ !
+ plan=0
+ if (irc.eq.0) then
+
+ call sfftw_plan_dft_r2c_3d(plan,nx,ny,nz,r,wk,FFTW_ESTIMATE)
+ call sfftw_execute(plan)
+ call sfftw_destroy_plan(plan)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=wk(i,j,k)/nx/ny/nz
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-1)=wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-1)=wk(i,j+nys2+1,k)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-nzs2)=wk(i,j,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-nzs2)=wk(i,j+nys2+1,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+
+ else
+
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k)=c(i-1,j-1,k-1)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k)=c(i-1,j-nys2,k-1)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k+nzs2+1)=c(i-1,j-1,k-nzs2)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k+nzs2+1)=c(i-1,j-nys2,k-nzs2)
+ enddo
+ enddo
+ enddo
+
+ call sfftw_plan_dft_c2r_3d(plan,nx,ny,nz,wk,r,FFTW_ESTIMATE)
+ call sfftw_execute(plan)
+ call sfftw_destroy_plan(plan)
+
+ endif
+
+ return
+end subroutine fftw3d
diff --git a/CodesEnVrac/CodeGH/src-common/param.i b/CodesEnVrac/CodeGH/src-common/param.i
new file mode 100644
index 0000000000000000000000000000000000000000..fe75c83f0bd49aaebeeb0262ab3a4eb782cc76c5
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-common/param.i
@@ -0,0 +1,2 @@
+ parameter(npm=2100000,npgx=128,npgy=128,npgz=128)
+ parameter(npg=npgx)
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/array.h b/CodesEnVrac/CodeGH/src-sphere/NotUsed/array.h
new file mode 100644
index 0000000000000000000000000000000000000000..3d4ab26a702365a74c1bbb91b646aec8e5750bea
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/array.h
@@ -0,0 +1,6 @@
+ COMMON/GRID/ omg1(-1:npg,-1:npg,-1:npg),
+ & omg2(-1:npg,-1:npg,-1:npg),omg3(-1:npg,-1:npg,-1:npg),
+ & vxg(npg,npg,npg),vyg(npg,npg,npg),vzg(npg,npg,npg),
+ & psi1(npg,npg,npg),psi2(npg,npg,npg),psi3(npg,npg,npg),
+ & strg1(npg,npg,npg),strg2(npg,npg,npg),strg3(npg,npg,npg)
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/bar.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/bar.f
new file mode 100644
index 0000000000000000000000000000000000000000..479b896e40872ba4185f48ca0e6a921f1e1ba1f4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/bar.f
@@ -0,0 +1,55 @@
+ subroutine bar(saut)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+c calcul du terme barotrope
+c -1/rho(curl rho).(grad p)/rho
+
+
+ pi=3.1415926
+ topi=2./pi
+ spi=sqrt(pi)
+
+ eps=dx*width
+ eps2=eps**2
+
+ dxinv=1./(2.*dx)
+ dyinv=1./(2.*dy)
+
+c terme barotrope
+
+ astr=0.
+ do i=1,nx
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do k=1,nz
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ arg=phig(i,j,k)
+ rho=1.+arg
+ argx=phig(it,j,k)-phig(ib,j,k)
+ argy=phig(i,jt,k)-phig(i,jb,k)
+ argz=phig(i,j,kt)-phig(i,j,kb)
+ sautz=-1.-dvz(i,j,k)/rho
+ sautx=-dvx(i,j,k)/rho
+ sauty=-dvy(i,j,k)/rho
+ strg1(i,j,k)=strg1(i,j,k)+(argy*sautz-argz*sauty)/(2.*dx)
+ strg2(i,j,k)=strg2(i,j,k)+(argz*sautx-argx*sautz)/(2.*dx)
+ strg3(i,j,k)=strg3(i,j,k)+(argx*sauty-argy*sautx)/(2.*dx)
+ astr=amax1(astr,abs(strg1(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+111 continue
+
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/common4grid.h b/CodesEnVrac/CodeGH/src-sphere/NotUsed/common4grid.h
new file mode 100644
index 0000000000000000000000000000000000000000..f6226d7fd5e7de5e3e8e6b6c5030dd0189eb0f71
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/common4grid.h
@@ -0,0 +1,6 @@
+ COMMON/GRID/ omg1(-1:npgx,-1:npgy,-1:npgz),
+ & omg2(-1:npgx,-1:npgy,-1:npgz),omg3(-1:npgx,-1:npgy,-1:npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),strg3(npgx,npgy,npgz)
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/diag.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/diag.f
new file mode 100644
index 0000000000000000000000000000000000000000..6fe9a2798135843fc404209dc735abfcc9d2794c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/diag.f
@@ -0,0 +1,56 @@
+ subroutine diag(ener,enstro,div,omax)
+
+c calcul sur une grille mxmxm de (a,b)**3 du
+c div w, enstro et energy
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+
+ eps3=dx*dy*dz
+ vol=eps3
+
+ dxinv2=0.5/dx
+ dyinv2=0.5/dy
+ dzinv2=0.5/dz
+
+ omax=0.
+ div=0.
+ domax=0.
+ ener=0.
+ enstro=0.
+ do 10 i=1,nx
+ it=mod(i,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ do 10 j=1,ny
+ jt=mod(j,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do 20 k=1,nz
+ kt=mod(k,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ aux1=omg1(it,j,k)-omg1(ib,j,k)
+ aux2=omg2(i,jt,k)-omg2(i,jb,k)
+ aux3=(omg3(i,j,kt)-omg3(i,j,kb))
+ psi1(i,j,k)=(aux1*dxinv2+aux2*dyinv2+aux3*dzinv2)
+ div=div+((aux1*dxinv2+aux2*dyinv2+aux3*dzinv2)**2)*eps3
+ domax=domax+((abs(aux1*dxinv2)+abs(aux2*dyinv2)+
+ 1 abs(aux3*dzinv2))**2)*eps3
+ enerx=vxg(i,j,k)*vxg(i,j,k)
+ enery=vyg(i,j,k)*vyg(i,j,k)
+ enerz=vzg(i,j,k)*vzg(i,j,k)
+ strengthx=omg1(i,j,k)*omg1(i,j,k)
+ strengthy=omg2(i,j,k)*omg2(i,j,k)
+ strengthz=omg3(i,j,k)*omg3(i,j,k)
+ omax=amax1(omax,sqrt(strengthx+strengthy+strengthz))
+ enstro=enstro+(strengthx+strengthy+strengthz)*vol
+ ener=ener+(enerx+enery+enerz)*vol
+20 continue
+10 continue
+
+ if (domax.ne.0) div=div/domax
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif.f
new file mode 100644
index 0000000000000000000000000000000000000000..fd94b05c30ed88ecc0f13b907ebbf08c3233e3ea
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif.f
@@ -0,0 +1,154 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE dif_om(npart,om1,om2,om3,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax1)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ dxinv=1./(dx1)
+ dy1=dx1
+ dz1=dx1
+ dyinv=dxinv
+ dzinv=dxinv
+
+ npart=0
+ vol=dx1**3
+
+ do k=1,nz1
+ z=zmin+(k-1)*dz1
+ do j=1,ny1
+ y=ymin+(j-1)*dy1
+ do i=1,nx1
+ x=xmin+(i-1)*dx1
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx1**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ enddo
+ enddo
+ enddo
+
+c goto 1001
+
+ dzdx=(dz1/dx1)**2
+ dzdy=(dz1/dy1)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+c boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+c boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx1-1,nx1)+1
+ j2=mod(jj+ly+ny1-1,ny1)+1
+ k2=mod(kk+lz+nz1-1,nz1)+1
+ gammasrc1=omg1(i2,j2,k2)*vol
+ gammasrc2=omg2(i2,j2,k2)*vol
+ gammasrc3=omg3(i2,j2,k2)*vol
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ dvx=(vxsrc-vxrcv)/dx1
+ dvy=(vysrc-vyrcv)/dy1
+ dvz=(vzsrc-vzrcv)/dz1
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ ales=amax1(0.,-dvx*lx-dvy*ly-dvz*lz)
+c ales=abs(dvx*lx+dvy*ly+dvz*lz)
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ akernel2=2.5/((1.+r)*2.8333)
+ factor=akernel/(dz1*dz1)
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy1*dx1*dz1/dv1(i))
+
+c enddo pour caluc de dom sur les particules
+ enddo
+
+1001 continue
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv1(i))
+ omax0=amax1(omax0,abs(om2(i))/dv1(i))
+ omax0=amax1(omax0,abs(om3(i))/dv1(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv1(i))
+ omax1=amax1(omax1,abs(om2(i))/dv1(i))
+ omax1=amax1(omax1,abs(om3(i))/dv1(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif_om_part.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif_om_part.f
new file mode 100644
index 0000000000000000000000000000000000000000..fd94b05c30ed88ecc0f13b907ebbf08c3233e3ea
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/dif_om_part.f
@@ -0,0 +1,154 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE dif_om(npart,om1,om2,om3,
+ 1 xp1,yp1,zp1,dv1,anu,delt,coef_les,omax1)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ dxinv=1./(dx1)
+ dy1=dx1
+ dz1=dx1
+ dyinv=dxinv
+ dzinv=dxinv
+
+ npart=0
+ vol=dx1**3
+
+ do k=1,nz1
+ z=zmin+(k-1)*dz1
+ do j=1,ny1
+ y=ymin+(j-1)*dy1
+ do i=1,nx1
+ x=xmin+(i-1)*dx1
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx1**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ enddo
+ enddo
+ enddo
+
+c goto 1001
+
+ dzdx=(dz1/dx1)**2
+ dzdy=(dz1/dy1)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+c boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+c boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx1-1,nx1)+1
+ j2=mod(jj+ly+ny1-1,ny1)+1
+ k2=mod(kk+lz+nz1-1,nz1)+1
+ gammasrc1=omg1(i2,j2,k2)*vol
+ gammasrc2=omg2(i2,j2,k2)*vol
+ gammasrc3=omg3(i2,j2,k2)*vol
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ dvx=(vxsrc-vxrcv)/dx1
+ dvy=(vysrc-vyrcv)/dy1
+ dvz=(vzsrc-vzrcv)/dz1
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ ales=amax1(0.,-dvx*lx-dvy*ly-dvz*lz)
+c ales=abs(dvx*lx+dvy*ly+dvz*lz)
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ akernel2=2.5/((1.+r)*2.8333)
+ factor=akernel/(dz1*dz1)
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*
+ 1 (anu*factor+coef_les*ales*akernel2)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy1*dx1*dz1/dv1(i))
+
+c enddo pour caluc de dom sur les particules
+ enddo
+
+1001 continue
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv1(i))
+ omax0=amax1(omax0,abs(om2(i))/dv1(i))
+ omax0=amax1(omax0,abs(om3(i))/dv1(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv1(i))
+ omax1=amax1(omax1,abs(om2(i))/dv1(i))
+ omax1=amax1(omax1,abs(om3(i))/dv1(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw3d_new.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw3d_new.f
new file mode 100644
index 0000000000000000000000000000000000000000..cd940baf56be335ad61d39e1c92f501fc0fed84e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw3d_new.f
@@ -0,0 +1,155 @@
+ subroutine fftw3d(r,c,nx,ny,nz,nxs2,nys2,nzs2,wk,irc)
+c
+c Ce programme calcul la transformee de fourier rapide
+c
+C----------------------------------------------------------------------
+C TRANSFORMATION DE FOURIER REELLE<--->COMPLEXE TRI-DIMENSIONNELLE
+C X : VECTEUR REEL DE DIMENSION (nx,ny,nz)
+C C : VECTEUR COMPLEXE DE DIMENSION (0:nx/2,-ny/2+1:ny/2,-nz/2+1:nz/2)
+C WK : Vecteur de travail pour les fftw de dimension (0:nx/2,0:ny-1,0:nz-1)
+C IRC : =0: REELLE ---> COMPLEXE (X-->C) Directe
+C <>0: COMPLEXE ---> REELLE (C-->X) inverse
+C
+C REMARQUE:
+C CALCULE LA TRANSFORMATION SUIVANTE:
+C
+C X(J,K,L) J(1..nx),K(1..ny),L(1..Nz) <---> C(J,K,L) J=0..nx/2 K=-ny/2+1,...,ny/2,
+C L=-nz/2+1,...,nz/2
+C
+C----------------------------------------------------------------------
+c
+c Declaration pour utiliser les routines fftw
+c
+c This file contains PARAMETER statements for various constants
+c that can be passed to FFTW routines. You should include
+c this file in any FORTRAN program that calls the fftw_f77
+c routines (either directly or with an #include statement
+c if you use the C preprocessor).
+c
+ INTEGER FFTW_FORWARD,FFTW_BACKWARD
+ PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+c
+ INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+ PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+c
+ INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+ PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+c
+ INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+ PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
+c
+ integer plan,nx,ny,nz,nxs2,nys2,nzs2,irc,i,j,k
+c
+ complex c,wk
+ dimension c(0:nxs2,1-nys2:nys2,1-nzs2:nzs2),wk(nxs2+1,ny,nz)
+c
+ real r
+ dimension r(nx,ny,nz)
+c
+c print*,nx,ny,nz,nxs2,nys2,nzs2,r(2,5,1)
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=cmplx(0.0,0.0)
+ enddo
+ enddo
+ enddo
+c
+ if (irc.eq.0) then
+c
+ call rfftw3d_f77_create_plan(plan,nx,ny,nz,FFTW_FORWARD,
+ 1 FFTW_ESTIMATE)
+c 1 FFTW_MEASURE)
+c
+ call rfftwnd_f77_one_real_to_complex(plan,r,wk)
+c
+c print*,'coucou',wk(2,5,1)
+ call rfftwnd_f77_destroy_plan(plan)
+c
+ do k=1,nz
+ do j=1,ny
+ do i=1,nxs2+1
+ wk(i,j,k)=wk(i,j,k)/nx/ny/nz
+ enddo
+ enddo
+ enddo
+c print*,wk(2,5,1)
+c
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-1)=wk(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-1)=wk(i,j+nys2+1,k)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ c(i-1,j-1,k-nzs2)=wk(i,j,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ c(i-1,j-nys2,k-nzs2)=wk(i,j+nys2+1,k+nzs2+1)
+ enddo
+ enddo
+ enddo
+c
+ else
+c
+ do k=1,nzs2+1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k)=c(i-1,j-1,k-1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2+1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k)=c(i-1,j-nys2,k-1)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2+1
+ do i=1,nxs2+1
+ wk(i,j,k+nzs2+1)=c(i-1,j-1,k-nzs2)
+ enddo
+ enddo
+ enddo
+c
+ do k=1,nzs2-1
+ do j=1,nys2-1
+ do i=1,nxs2+1
+ wk(i,j+nys2+1,k+nzs2+1)=c(i-1,j-nys2,k-nzs2)
+ enddo
+ enddo
+ enddo
+c
+ call rfftw3d_f77_create_plan(plan,nx,ny,nz,FFTW_BACKWARD,
+ 1 FFTW_ESTIMATE)
+c 1 FFTW_MEASURE)
+c
+ call rfftwnd_f77_one_complex_to_real(plan,wk,r)
+c
+ call rfftwnd_f77_destroy_plan(plan)
+c
+ endif
+c
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw_f77.i b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw_f77.i
new file mode 100644
index 0000000000000000000000000000000000000000..26c3524023481eeaead10895b12c4bd72e700ea4
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fftw_f77.i
@@ -0,0 +1,17 @@
+c This file contains PARAMETER statements for various constants
+c that can be passed to FFTW routines. You should include
+c this file in any FORTRAN program that calls the fftw_f77
+c routines (either directly or with an #include statement
+c if you use the C preprocessor).
+
+ INTEGER FFTW_FORWARD,FFTW_BACKWARD
+ PARAMETER (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
+
+ INTEGER FFTW_REAL_TO_COMPLEX,FFTW_COMPLEX_TO_REAL
+ PARAMETER (FFTW_REAL_TO_COMPLEX=-1,FFTW_COMPLEX_TO_REAL=1)
+
+ INTEGER FFTW_ESTIMATE,FFTW_MEASURE
+ PARAMETER (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
+
+ INTEGER FFTW_IN_PLACE,FFTW_USE_WISDOM
+ PARAMETER (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/fortranize.h b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fortranize.h
new file mode 100644
index 0000000000000000000000000000000000000000..fb4a6b8b6dac73c64abd27aa3013338ea6be7ebb
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/fortranize.h
@@ -0,0 +1,50 @@
+/*
+ * Copyright (c) 1997,1998 Massachusetts Institute of Technology
+ *
+ * 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *
+ */
+
+#ifndef FORTRANIZE_H
+#define FORTRANIZE_H
+
+/*
+ * convert C name -> FORTRAN name. On some systems,
+ * append an underscore. On other systems, use all caps.
+ *
+ * x is the lower case name, X is the all caps name.
+ */
+
+#if defined(CRAY) || defined(_UNICOS) || defined(_CRAYMPP)
+#define FORTRANIZE(x,X) X /* all upper-case on the Cray */
+
+#elif defined(IBM6000) || defined(_AIX)
+#define FORTRANIZE(x,X) x /* all lower-case on RS/6000 */
+
+#elif defined(__hpux)
+#define FORTRANIZE(x,X) x /* all lower-case on HP-UX */
+
+#elif defined(USING_G77) /* users should define this when using with the g77
+ Fortran compiler */
+#define FORTRANIZE(x,X) x##__ /* g77 expects *two* underscores after
+ names with an underscore */
+
+#else
+#define FORTRANIZE(x,X) x##_ /* use all lower-case with underscore
+ by default */
+
+#endif
+
+#endif /* FORTRANIZE_H */
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/main_2ways.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/main_2ways.f
new file mode 100644
index 0000000000000000000000000000000000000000..5f692d83863c9009df6514f15679e7a90bb43528
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/main_2ways.f
@@ -0,0 +1,273 @@
+ program cylindre
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp(npm),yp(npm),zp(npm),dv(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx(npm),vy(npm),vz(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+
+ dimension domx(npm),domy(npm),domz(npm)
+c tableuax supplementaries pour RK
+ dimension xp0(npm),yp0(npm),zp0(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv(4,npm),vyv(4,npm),vzv(4,npm)
+ dimension para(4)
+ dimension enstrophy(0:1000),energy(0:1000),divergence(0:1000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filevelx,filevely,filevelz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+
+
+
+
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx
+ READ(1,*)
+ read(1,*)tstop
+ READ(1,*)
+ read(1,*)coef
+ READ(1,*)
+ read(1,*)anu
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tvisu
+ READ(1,*)
+ read(1,*) width
+
+
+ close(1)
+ tvisu=0.3
+ idif=1
+
+ xmin=-0.
+ xmax=1.
+ ymin=0.
+ ymax=1.
+ zmin=xmin
+ zmax=xmax
+
+ ny=nx
+ nz=nx
+ dx=(xmax-xmin)/(nx)
+ dy=(ymax-ymin)/(ny)
+ dz=(zmax-zmin)/(nz)
+
+ delt=0.01
+
+
+ call init(npart,xp,yp,zp,omx,omy,omz,dv)
+
+ OPEN(33,file='SPEED',status='unknown')
+
+c debut des iterations
+
+ time=0.
+ tcompt=0.
+ istep=0
+ nit=10000
+
+ do 20 kk=1,nit
+
+ time=time+delt
+
+ deltconv=delt
+ delt1=delt/6.
+
+ call velox_fft
+ call vfix
+c call vhat(delt)
+
+ print*, ' VITESSE = ',vzh
+
+ call pen(coef_pen,omx,omy,omz,delt)
+c call bar(saut)
+
+ call stretch
+
+
+
+c on fait les sous-iterations R.K.
+
+ do 10 i=1,npart
+ xp0(i)=xp(i)
+ yp0(i)=yp(i)
+ zp0(i)=zp(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+10 continue
+
+ do 550 ll=1,4
+
+ call intervm4(npart,vx,vy,vz,xp,yp,zp)
+ call intersm4(npart,strx,stry,strz,xp,yp,zp)
+
+c increment des positions et poids correspondant aux sous-ite
+c RK
+c **********************
+
+ vxmax=0.
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ vzmax=0.
+ do 520 i=1,npart
+ vxv(ll,i)=vx(i)
+ vyv(ll,i)=vy(i)
+ vzv(ll,i)=vz(i)
+ strxv(ll,i)=dv(i)*strx(i)
+ stryv(ll,i)=dv(i)*stry(i)
+ strzv(ll,i)=dv(i)*strz(i)
+ xp(i)=xp0(i)+para(ll)*deltconv*vx(i)
+ if (xp(i).lt.xmin) xp(i)=xp(i)+xmax-xmin
+ if (xp(i).gt.xmax) xp(i)=xp(i)-xmax+xmin
+ yp(i)=yp0(i)+para(ll)*deltconv*vy(i)
+ if (yp(i).lt.ymin) yp(i)=yp(i)+ymax-ymin
+ if (yp(i).gt.ymax) yp(i)=yp(i)-ymax+ymin
+ zp(i)=zp0(i)+para(ll)*deltconv*vz(i)
+ if (zp(i).lt.zmin) zp(i)=zp(i)+zmax-zmin
+ if (zp(i).gt.zmax) zp(i)=zp(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv(i)*strz(i)
+ vxmax=amax1(vxmax,(vx(i)))
+ vxmin=amin1(vxmin,(vx(i)))
+ vymax=amax1(vymax,(vy(i)))
+ vymin=amin1(vymin,(vy(i)))
+ vzmax=amax1(vzmax,(vz(i)))
+ vzmin=amin1(vzmin,(vz(i)))
+520 continue
+c print*,' vitesses max ',vxmax,vxmin,vymax,vymin,vzmax,vzmin
+
+550 continue
+
+c FIN des sous-ite RK
+c **********************
+
+c Increments des positions et poids pour
+c la partie transport-deformation du tourbillon
+
+
+ xleft=xmax
+ xright=xmin
+ yleft=ymax
+ yright=ymin
+ zleft=zmax
+ zright=zmin
+ do 900 i=1,npart
+ xp(i)=xp0(i)+delt1*(vxv(1,i)+2.*vxv(2,i)+2.*vxv(3,i)+vxv(4,i))
+ yp(i)=yp0(i)+delt1*(vyv(1,i)+2.*vyv(2,i)+2.*vyv(3,i)+vyv(4,i))
+ zp(i)=zp0(i)+delt1*(vzv(1,i)+2.*vzv(2,i)+2.*vzv(3,i)+vzv(4,i))
+ zp(i)=zp(i)-delt*vzh
+ xleft=amin1(xleft,xp(i))
+ xright=amax1(xright,xp(i))
+ yleft=amin1(yleft,yp(i))
+ yright=amax1(yright,yp(i))
+ zleft=amin1(zleft,zp(i))
+ zright=amax1(zright,zp(i))
+ if (xp(i).lt.xmin) xp(i)=xp(i)+xmax-xmin
+ if (xp(i).gt.xmax) xp(i)=xp(i)-xmax+xmin
+ if (yp(i).lt.ymin) yp(i)=yp(i)+ymax-ymin
+ if (yp(i).gt.ymax) yp(i)=yp(i)-ymax+ymin
+ if (zp(i).lt.zmin) zp(i)=zp(i)+zmax-zmin
+ if (zp(i).gt.zmax) zp(i)=zp(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+
+ 1 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+
+ 1 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+
+ 1 2.*strzv(3,i)+strzv(4,i))
+900 continue
+
+
+
+
+c Remshing + Diffusion
+c **********************
+
+c circlim=0.0001
+c circulation mimimum pour troncature de la vorticite dans remaillage
+ circlim=-10.
+
+
+ call remeshdif(npart,circlim,omx,omy,omz,
+ 1 xp,yp,zp,dv,anu,delt)
+
+ print*,' npart apres remeshing ', kk,npart
+
+ xg=0.
+ yg=0.
+ zg=0.
+ tm=0.
+
+ if ((tcompt.gt.tvisu).or.(kk.eq.0)) then
+ istep=istep+1
+ print*, ' ****** IMPRESSION des RESULTATS: ', istep, ' ******'
+
+ write(filevelx,140)istep
+140 format('velx',i1)
+ if (istep.ge.10) then
+ write(filevelx,141)istep
+ endif
+141 format('velx',i2)
+ write(filevely,150)istep
+150 format('vely',i1)
+ if (istep.ge.10) then
+ write(filevely,151)istep
+ endif
+151 format('vely',i2)
+ write(filevelz,160)istep
+160 format('velz',i1)
+ if (istep.ge.10) then
+ write(filevelz,161)istep
+ endif
+161 format('velz',i2)
+
+ open(2,file=filevelx,form='unformatted',
+c 1 convert='big_endian',
+ 1 status='unknown')
+ open(3,file=filevely,form='unformatted',
+c 1 convert='big_endian',
+ 1 status='unknown')
+ open(4,file=filevelz,form='unformatted',
+c 1 convert='big_endian',
+ 1 status='unknown')
+ write(2) (((vxg(i,j,k),
+ 1 i=1,nx),j=1,ny),k=1,nz)
+ write(3) (((vyg(i,j,k),
+ 1 i=1,nx),j=1,ny),k=1,nz)
+ write(4) (((vzg(i,j,k),
+ 1 i=1,nx),j=1,ny),k=1,nz)
+ close(2)
+ close(3)
+ close(4)
+
+ tcompt=0.
+ endif
+
+ write(32,*) time,vzh
+
+ if (time.gt.5.) goto 201
+
+20 continue
+
+201 continue
+ stop
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/makefile b/CodesEnVrac/CodeGH/src-sphere/NotUsed/makefile
new file mode 100644
index 0000000000000000000000000000000000000000..6edcdf30f2c99a0e672aeed2b51ef8e4e68c8b44
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/makefile
@@ -0,0 +1,37 @@
+#
+# la commande f77 pour les dec est f77_520
+#
+FF =ifort
+OPT = -I/${INCLUDE}
+
+OPT2 = -O3 -tpp2 -ipo -nolib_inline -ipo_obj -ldl
+
+OPT4 = -g
+OPT3 = -O3 -tpp2 -ldl -g
+
+CFLAGS = -pg -DUSING_G77
+
+FFLAGS = -O3
+
+LDFLAGS = -pg
+
+PROGRAM = vicper256b
+
+EXEC = vicper256b
+
+all: $(PROGRAM)
+
+
+OBJ = main.o init.o reinit.o \
+ vfix.o drag.o drag_surface.o \
+intervm4.o remesh.o \
+dif_om.o remesh_om.o \
+intersm4.o stretch.o pen_dif_fft.o \
+pen.o fftw3d.o velox_fft.o velox_dif.o diff_fft.o
+
+%.o: %.f param.i arrays.h
+ $(FF) -o $@ -c $< $(OPT3)
+
+
+$(PROGRAM): $(OBJ)
+ ifort $(OPT3) $(OBJ) -lfftw3f -lfftw3_threads -lfftw3 -o $(EXEC)
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_expl.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_expl.f
new file mode 100644
index 0000000000000000000000000000000000000000..a53f0daf203932c3a9f2b462e90faccb0583545c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_expl.f
@@ -0,0 +1,47 @@
+ subroutine pen(coef_pen)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+c condition limite v=v_h en vorticite par penalisation explicite
+
+ pi=3.1415926
+ topi=2./pi
+ spi=sqrt(pi)
+
+ eps=float(nc)*dx
+ eps=dx/1000.
+ eps2=eps**2
+
+ dxinv=1./(2.*dx)
+ dyinv=1./(2.*dy)
+
+
+c penalisation sous forme : curl[ (v-vh)H]
+
+ do i=1,nx
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ arg=phig(i,j)
+ argt=phig(it,j)
+ argb=phig(ib,j)
+ term1=(coef_pen*(vyh-vyg(it,j)))*argt
+ term2=(coef_pen*(vyh-vyg(ib,j)))*argb
+ akappa(i,j)=(term1-term2)/(2.*dx)
+ argt=phig(i,jt)
+ argb=phig(i,jb)
+ term1=(coef_pen*(vxh-vxg(i,jt)))*argt
+ term2=(coef_pen*(vxh-vxg(i,jb)))*argb
+ akappa(i,j)=akappa(i,j)-(term1-term2)/(2.*dx)
+ enddo
+ enddo
+
+111 continue
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_impl.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_impl.f
new file mode 100644
index 0000000000000000000000000000000000000000..b4f5817a5f4eeac6b644610d5c4e0faeb7eeffc3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/pen_impl.f
@@ -0,0 +1,86 @@
+ subroutine pen(coef_pen,omx,omy,omz,delt)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension domg(npg,npg,npg)
+ dimension omx(*),omy(*),omz(*)
+
+c condition limite v=vh par penalisation implicite en vorticite
+
+ pi=3.1415926
+ topi=2./pi
+ spi=sqrt(pi)
+
+ eps=float(nc)*dx
+ eps=dx/1000.
+ eps2=eps**2
+
+ dxinv=1./(2.*dx)
+ dyinv=1./(2.*dy)
+
+ cdelt=coef_pen*delt
+
+
+c penalisation sous forme :
+c omega_n+1=curl[(u_n+coef_pen*delt*vh)/(1+coef_pen)]
+
+ npart=0
+ do k=1,nz
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do i=1,nx
+ npart=npart+1
+ strg1(i,j)=0.
+ strg3(i,j)=0.
+ strg3(i,j)=0.
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ arg=phig(i,j,k)
+ argt=phig(i,jt,k)
+ argb=phig(i,jb,k)
+ argu=phig(i,j,kt)
+ argd=phig(i,j,kb)
+ argr=phig(it,j,k)
+ argl=phig(ib,j,k)
+
+c x-component:
+ term1=(vzg(i,jt,k)+argt*cdelt*vzh)/(1.+cdelt*argt)
+ term2=(vzg(i,jb,k)+argb*cdelt*vzh)/(1.+cdelt*argb)
+ domg(i,j,k)=(term1-term2)/(2.*dx)-omg1(i,j,k)
+ term1=(vyg(i,j,kt)+argu*cdelt*vyh)/(1.+cdelt*argu)
+ term2=(vyg(i,j,kb)+argd*cdelt*vyh)/(1.+cdelt*argd)
+ domg(i,j,k)=domg(i,j,k)-(term1-term2)/(2.*dx)
+ omx(npart)=omx(npart)+(dx**2)*domg(i,j,k)
+
+c y-component:
+ term1=(vxg(i,j,kt)+argu*cdelt*vxh)/(1.+cdelt*argu)
+ term2=(vxg(i,j,kb)+argd*cdelt*vxh)/(1.+cdelt*argd)
+ domg(i,j,k)=(term1-term2)/(2.*dx)-omg2(i,j,k)
+ term1=(vzg(it,j,k)+argr*cdelt*vzh)/(1.+cdelt*argr)
+ term2=(vzg(ib,j,k)+argl*cdelt*vzh)/(1.+cdelt*argl)
+ omy(npart)=omy(npart)+(dx**2)*domg(i,j,k)
+
+c z-component:
+ term1=(vyg(it,j,k)+argu*cdelt*vyh)/(1.+cdelt*argr)
+ term2=(vyg(ib,j,k)+argd*cdelt*vyh)/(1.+cdelt*argl)
+ domg(i,j,k)=(term1-term2)/(2.*dx)-omg3(i,j,k)
+ term1=(vxg(i,jt,k)+argr*cdelt*vxh)/(1.+cdelt*argt)
+ term2=(vxg(i,jb,k)+argl*cdelt*vxh)/(1.+cdelt*argb)
+ omz(npart)=omz(npart)+(dx**2)*domg(i,j,k)
+
+ enddo
+ enddo
+ enddo
+
+
+
+111 continue
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/poisson.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/poisson.f
new file mode 100644
index 0000000000000000000000000000000000000000..a365591c5efd27968cb1e36565730d513cb0e897
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/poisson.f
@@ -0,0 +1,4477 @@
+ SUBROUTINE CFFTB(N,C,WSAVE)
+C***BEGIN PROLOGUE CFFTB
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 851111 (YYMMDD)
+C***CATEGORY NO. J1A2
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Unnormalized inverse of CFFTF.
+C***DESCRIPTION
+C
+C Subroutine CFFTB computes the backward complex discrete Fourier
+C transform (the Fourier synthesis). Equivalently, CFFTB computes
+C a complex periodic sequence from its Fourier coefficients.
+C The transform is defined below at output parameter C.
+C
+C A call of CFFTF followed by a call of CFFTB will multiply the
+C sequence by N.
+C
+C The array WSAVE which is used by subroutine CFFTB must be
+C initialized by calling subroutine CFFTI(N,WSAVE).
+C
+C Input Parameters
+C
+C
+C N the length of the complex sequence C. The method is
+C more efficient when N is the product of small primes.
+C
+C C a complex array of length N which contains the sequence
+C
+C WSAVE a real work array which must be dimensioned at least 4*N+15
+C in the program that calls CFFTB. The WSAVE array must be
+C initialized by calling subroutine CFFTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C The same WSAVE array can be used by CFFTF and CFFTB.
+C
+C Output Parameters
+C
+C C For J=1,...,N
+C
+C C(J)=the sum from K=1,...,N of
+C
+C C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
+C
+C where I=SQRT(-1)
+C
+C WSAVE contains initialization calculations which must not be
+C destroyed between calls of subroutine CFFTF or CFFTB
+C***REFERENCES (NONE)
+C***ROUTINES CALLED CFFTB1
+C***END PROLOGUE CFFTB
+ COMPLEX C
+ DIMENSION C(*) ,WSAVE(*)
+C***FIRST EXECUTABLE STATEMENT CFFTB
+ IF (N .EQ. 1) RETURN
+ IW1 = N+N+1
+ IW2 = IW1+N+N
+ CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
+ RETURN
+ END
+ SUBROUTINE CFFTB1(N,C,CH,WA,IFAC)
+C***BEGIN PROLOGUE CFFTB1
+C***REFER TO CFFTB
+C***ROUTINES CALLED PASSB,PASSB2,PASSB3,PASSB4,PASSB5
+C***END PROLOGUE CFFTB1
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)
+C***FIRST EXECUTABLE STATEMENT CFFTB1
+ NF = IFAC(2)
+ NA = 0
+ L1 = 1
+ IW = 1
+ DO 116 K1=1,NF
+ IP = IFAC(K1+2)
+ L2 = IP*L1
+ IDO = N/L2
+ IDOT = IDO+IDO
+ IDL1 = IDOT*L1
+ IF (IP .NE. 4) GO TO 103
+ IX2 = IW+IDOT
+ IX3 = IX2+IDOT
+ IF (NA .NE. 0) GO TO 101
+ CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 102
+ 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ 102 NA = 1-NA
+ GO TO 115
+ 103 IF (IP .NE. 2) GO TO 106
+ IF (NA .NE. 0) GO TO 104
+ CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
+ GO TO 105
+ 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
+ 105 NA = 1-NA
+ GO TO 115
+ 106 IF (IP .NE. 3) GO TO 109
+ IX2 = IW+IDOT
+ IF (NA .NE. 0) GO TO 107
+ CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 108
+ 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
+ 108 NA = 1-NA
+ GO TO 115
+ 109 IF (IP .NE. 5) GO TO 112
+ IX2 = IW+IDOT
+ IX3 = IX2+IDOT
+ IX4 = IX3+IDOT
+ IF (NA .NE. 0) GO TO 110
+ CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 111
+ 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ 111 NA = 1-NA
+ GO TO 115
+ 112 IF (NA .NE. 0) GO TO 113
+ CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ GO TO 114
+ 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ 114 IF (NAC .NE. 0) NA = 1-NA
+ 115 L1 = L2
+ IW = IW+(IP-1)*IDOT
+ 116 CONTINUE
+ IF (NA .EQ. 0) RETURN
+ N2 = N+N
+ DO 117 I=1,N2
+ C(I) = CH(I)
+ 117 CONTINUE
+ RETURN
+ END
+ SUBROUTINE CFFTF(N,C,WSAVE)
+C***BEGIN PROLOGUE CFFTF
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 851111 (YYMMDD)
+C***CATEGORY NO. J1A2
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Forward transform of a complex, periodic sequence.
+C***DESCRIPTION
+C
+C Subroutine CFFTF computes the forward complex discrete Fourier
+C transform (the Fourier analysis). Equivalently, CFFTF computes
+C the Fourier coefficients of a complex periodic sequence.
+C The transform is defined below at output parameter C.
+C
+C The transform is not normalized. To obtain a normalized transform
+C the output must be divided by N. Otherwise a call of CFFTF
+C followed by a call of CFFTB will multiply the sequence by N.
+C
+C The array WSAVE which is used by subroutine CFFTF must be
+C initialized by calling subroutine CFFTI(N,WSAVE).
+C
+C Input Parameters
+C
+C
+C N the length of the complex sequence C. The method is
+C more efficient when N is the product of small primes.
+C
+C C a complex array of length N which contains the sequence
+C
+C WSAVE a real work array which must be dimensioned at least 4*N+15
+C in the program that calls CFFTF. The WSAVE array must be
+C initialized by calling subroutine CFFTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C The same WSAVE array can be used by CFFTF and CFFTB.
+C
+C Output Parameters
+C
+C C for J=1,...,N
+C
+C C(J)=the sum from K=1,...,N of
+C
+C C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
+C
+C where I=SQRT(-1)
+C
+C WSAVE contains initialization calculations which must not be
+C destroyed between calls of subroutine CFFTF or CFFTB
+C***REFERENCES (NONE)
+C***ROUTINES CALLED CFFTF1
+C***END PROLOGUE CFFTF
+ COMPLEX C
+ DIMENSION C(*) ,WSAVE(*)
+C***FIRST EXECUTABLE STATEMENT CFFTF
+ IF (N .EQ. 1) RETURN
+ IW1 = N+N+1
+ IW2 = IW1+N+N
+ CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
+ RETURN
+ END
+ SUBROUTINE CFFTF1(N,C,CH,WA,IFAC)
+C***BEGIN PROLOGUE CFFTF1
+C***REFER TO CFFTF
+C***ROUTINES CALLED PASSF,PASSF2,PASSF3,PASSF4,PASSF5
+C***END PROLOGUE CFFTF1
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)
+C***FIRST EXECUTABLE STATEMENT CFFTF1
+ NF = IFAC(2)
+ NA = 0
+ L1 = 1
+ IW = 1
+ DO 116 K1=1,NF
+ IP = IFAC(K1+2)
+ L2 = IP*L1
+ IDO = N/L2
+ IDOT = IDO+IDO
+ IDL1 = IDOT*L1
+ IF (IP .NE. 4) GO TO 103
+ IX2 = IW+IDOT
+ IX3 = IX2+IDOT
+ IF (NA .NE. 0) GO TO 101
+ CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 102
+ 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ 102 NA = 1-NA
+ GO TO 115
+ 103 IF (IP .NE. 2) GO TO 106
+ IF (NA .NE. 0) GO TO 104
+ CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
+ GO TO 105
+ 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
+ 105 NA = 1-NA
+ GO TO 115
+ 106 IF (IP .NE. 3) GO TO 109
+ IX2 = IW+IDOT
+ IF (NA .NE. 0) GO TO 107
+ CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 108
+ 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
+ 108 NA = 1-NA
+ GO TO 115
+ 109 IF (IP .NE. 5) GO TO 112
+ IX2 = IW+IDOT
+ IX3 = IX2+IDOT
+ IX4 = IX3+IDOT
+ IF (NA .NE. 0) GO TO 110
+ CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 111
+ 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ 111 NA = 1-NA
+ GO TO 115
+ 112 IF (NA .NE. 0) GO TO 113
+ CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ GO TO 114
+ 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ 114 IF (NAC .NE. 0) NA = 1-NA
+ 115 L1 = L2
+ IW = IW+(IP-1)*IDOT
+ 116 CONTINUE
+ IF (NA .EQ. 0) RETURN
+ N2 = N+N
+ DO 117 I=1,N2
+ C(I) = CH(I)
+ 117 CONTINUE
+ RETURN
+ END
+ SUBROUTINE CFFTI(N,WSAVE)
+C***BEGIN PROLOGUE CFFTI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A2
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for CFFTF and CFFTB.
+C***DESCRIPTION
+C
+C Subroutine CFFTI initializes the array WSAVE which is used in
+C both CFFTF and CFFTB. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the sequence to be transformed
+C
+C Output Parameter
+C
+C WSAVE a work array which must be dimensioned at least 4*N+15.
+C The same work array can be used for both CFFTF and CFFTB
+C as long as N remains unchanged. Different WSAVE arrays
+C are required for different values of N. The contents of
+C WSAVE must not be changed between calls of CFFTF or CFFTB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED CFFTI1
+C***END PROLOGUE CFFTI
+ DIMENSION WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT CFFTI
+ IF (N .EQ. 1) RETURN
+ IW1 = N+N+1
+ IW2 = IW1+N+N
+ CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
+ RETURN
+ END
+ SUBROUTINE CFFTI1(N,WA,IFAC)
+C***BEGIN PROLOGUE CFFTI1
+C***REFER TO CFFTI
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE CFFTI1
+ DIMENSION WA(1) ,IFAC(1) ,NTRYH(4)
+ DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
+C***FIRST EXECUTABLE STATEMENT CFFTI1
+ NL = N
+ NF = 0
+ J = 0
+ 101 J = J+1
+ IF (J-4) 102,102,103
+ 102 NTRY = NTRYH(J)
+ GO TO 104
+ 103 NTRY = NTRY+2
+ 104 NQ = NL/NTRY
+ NR = NL-NTRY*NQ
+ IF (NR) 101,105,101
+ 105 NF = NF+1
+ IFAC(NF+2) = NTRY
+ NL = NQ
+ IF (NTRY .NE. 2) GO TO 107
+ IF (NF .EQ. 1) GO TO 107
+ DO 106 I=2,NF
+ IB = NF-I+2
+ IFAC(IB+2) = IFAC(IB+1)
+ 106 CONTINUE
+ IFAC(3) = 2
+ 107 IF (NL .NE. 1) GO TO 104
+ IFAC(1) = N
+ IFAC(2) = NF
+ TPI = 6.28318530717959
+ ARGH = TPI/FLOAT(N)
+ I = 2
+ L1 = 1
+ DO 110 K1=1,NF
+ IP = IFAC(K1+2)
+ LD = 0
+ L2 = L1*IP
+ IDO = N/L2
+ IDOT = IDO+IDO+2
+ IPM = IP-1
+ DO 109 J=1,IPM
+ I1 = I
+ WA(I-1) = 1.
+ WA(I) = 0.
+ LD = LD+L1
+ FI = 0.
+ ARGLD = FLOAT(LD)*ARGH
+ DO 108 II=4,IDOT,2
+ I = I+2
+ FI = FI+1.
+ ARG = FI*ARGLD
+ WA(I-1) = COS(ARG)
+ WA(I) = SIN(ARG)
+ 108 CONTINUE
+ IF (IP .LE. 5) GO TO 109
+ WA(I1-1) = WA(I-1)
+ WA(I1) = WA(I)
+ 109 CONTINUE
+ L1 = L2
+ 110 CONTINUE
+ RETURN
+ END
+ SUBROUTINE COSQB(N,X,WSAVE)
+C***BEGIN PROLOGUE COSQB
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Unnormalized inverse of COSQF.
+C***DESCRIPTION
+C
+C Subroutine COSQB computes the fast Fourier transform of quarter
+C wave data. That is, COSQB computes a sequence from its
+C representation in terms of a cosine series with odd wave numbers.
+C The transform is defined below at output parameter X.
+C
+C COSQB is the unnormalized inverse of COSQF since a call of COSQB
+C followed by a call of COSQF will multiply the input sequence X
+C by 4*N.
+C
+C The array WSAVE which is used by subroutine COSQB must be
+C initialized by calling subroutine COSQI(N,WSAVE).
+C
+C
+C Input Parameters
+C
+C N the length of the array X to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C WSAVE a work array that must be dimensioned at least 3*N+15
+C in the program that calls COSQB. The WSAVE array must be
+C initialized by calling subroutine COSQI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X For I=1,...,N
+C
+C X(I)= the sum from K=1 to K=N of
+C
+C 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N))
+C
+C A call of COSQB followed by a call of
+C COSQF will multiply the sequence X by 4*N.
+C Therefore COSQF is the unnormalized inverse
+C of COSQB.
+C
+C WSAVE contains initialization calculations which must not
+C be destroyed between calls of COSQB or COSQF.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED COSQB1
+C***END PROLOGUE COSQB
+ DIMENSION X(1) ,WSAVE(1)
+ DATA TSQRT2 /2.82842712474619/
+C***FIRST EXECUTABLE STATEMENT COSQB
+ IF (N-2) 101,102,103
+ 101 X(1) = 4.*X(1)
+ RETURN
+ 102 X1 = 4.*(X(1)+X(2))
+ X(2) = TSQRT2*(X(1)-X(2))
+ X(1) = X1
+ RETURN
+ 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1))
+ RETURN
+ END
+ SUBROUTINE COSQB1(N,X,W,XH)
+C***BEGIN PROLOGUE COSQB1
+C***REFER TO COSQB
+C***ROUTINES CALLED RFFTB
+C***END PROLOGUE COSQB1
+ DIMENSION X(1) ,W(1) ,XH(1)
+C***FIRST EXECUTABLE STATEMENT COSQB1
+ NS2 = (N+1)/2
+ NP2 = N+2
+ DO 101 I=3,N,2
+ XIM1 = X(I-1)+X(I)
+ X(I) = X(I)-X(I-1)
+ X(I-1) = XIM1
+ 101 CONTINUE
+ X(1) = X(1)+X(1)
+ MODN = MOD(N,2)
+ IF (MODN .EQ. 0) X(N) = X(N)+X(N)
+ CALL RFFTB (N,X,XH)
+ DO 102 K=2,NS2
+ KC = NP2-K
+ XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K)
+ XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC)
+ 102 CONTINUE
+ IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1))
+ DO 103 K=2,NS2
+ KC = NP2-K
+ X(K) = XH(K)+XH(KC)
+ X(KC) = XH(K)-XH(KC)
+ 103 CONTINUE
+ X(1) = X(1)+X(1)
+ RETURN
+ END
+ SUBROUTINE COSQF(N,X,WSAVE)
+C***BEGIN PROLOGUE COSQF
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Forward cosine transform with odd wave numbers.
+C***DESCRIPTION
+C
+C Subroutine COSQF computes the fast Fourier transform of quarter
+C wave data. That is, COSQF computes the coefficients in a cosine
+C series representation with only odd wave numbers. The transform
+C is defined below at Output Parameter X
+C
+C COSQF is the unnormalized inverse of COSQB since a call of COSQF
+C followed by a call of COSQB will multiply the input sequence X
+C by 4*N.
+C
+C The array WSAVE which is used by subroutine COSQF must be
+C initialized by calling subroutine COSQI(N,WSAVE).
+C
+C
+C Input Parameters
+C
+C N the length of the array X to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15
+C in the program that calls COSQF. The WSAVE array must be
+C initialized by calling subroutine COSQI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X For I=1,...,N
+C
+C X(I) = X(1) plus the sum from K=2 to K=N of
+C
+C 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N))
+C
+C A call of COSQF followed by a call of
+C COSQB will multiply the sequence X by 4*N.
+C Therefore COSQB is the unnormalized inverse
+C of COSQF.
+C
+C WSAVE contains initialization calculations which must not
+C be destroyed between calls of COSQF or COSQB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED COSQF1
+C***END PROLOGUE COSQF
+ DIMENSION X(1) ,WSAVE(1)
+ DATA SQRT2 /1.4142135623731/
+C***FIRST EXECUTABLE STATEMENT COSQF
+ IF (N-2) 102,101,103
+ 101 TSQX = SQRT2*X(2)
+ X(2) = X(1)-TSQX
+ X(1) = X(1)+TSQX
+ 102 RETURN
+ 103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
+ RETURN
+ END
+ SUBROUTINE COSQF1(N,X,W,XH)
+C***BEGIN PROLOGUE COSQF1
+C***REFER TO COSQF
+C***ROUTINES CALLED RFFTF
+C***END PROLOGUE COSQF1
+ DIMENSION X(1) ,W(1) ,XH(1)
+C***FIRST EXECUTABLE STATEMENT COSQF1
+ NS2 = (N+1)/2
+ NP2 = N+2
+ DO 101 K=2,NS2
+ KC = NP2-K
+ XH(K) = X(K)+X(KC)
+ XH(KC) = X(K)-X(KC)
+ 101 CONTINUE
+ MODN = MOD(N,2)
+ IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
+ DO 102 K=2,NS2
+ KC = NP2-K
+ X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
+ X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
+ 102 CONTINUE
+ IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
+ CALL RFFTF (N,X,XH)
+ DO 103 I=3,N,2
+ XIM1 = X(I-1)-X(I)
+ X(I) = X(I-1)+X(I)
+ X(I-1) = XIM1
+ 103 CONTINUE
+ RETURN
+ END
+ SUBROUTINE COSQI(N,WSAVE)
+C***BEGIN PROLOGUE COSQI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for COSQF and COSQB.
+C***DESCRIPTION
+C
+C Subroutine COSQI initializes the array WSAVE which is used in
+C both COSQF and COSQB. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the array to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C Output Parameter
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15.
+C The same work array can be used for both COSQF and COSQB
+C as long as N remains unchanged. Different WSAVE arrays
+C are required for different values of N. The contents of
+C WSAVE must not be changed between calls of COSQF or COSQB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTI
+C***END PROLOGUE COSQI
+ DIMENSION WSAVE(1)
+ DATA PIH /1.57079632679491/
+C***FIRST EXECUTABLE STATEMENT COSQI
+ DT = PIH/FLOAT(N)
+ FK = 0.
+ DO 101 K=1,N
+ FK = FK+1.
+ WSAVE(K) = COS(FK*DT)
+ 101 CONTINUE
+ CALL RFFTI (N,WSAVE(N+1))
+ RETURN
+ END
+ SUBROUTINE COST(N,X,WSAVE)
+C***BEGIN PROLOGUE COST
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 851219 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Cosine transform of a real, even sequence.
+C***DESCRIPTION
+C
+C Subroutine COST computes the discrete Fourier cosine transform
+C of an even sequence X(I). The transform is defined below at output
+C parameter X.
+C
+C COST is the unnormalized inverse of itself since a call of COST
+C followed by another call of COST will multiply the input sequence
+C X by 2*(N-1). The transform is defined below at output parameter X.
+C
+C The array WSAVE which is used by subroutine COST must be
+C initialized by calling subroutine COSTI(N,WSAVE).
+C
+C Input Parameters
+C
+C N the length of the sequence X. N must be greater than 1.
+C The method is most efficient when N-1 is a product of
+C small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15
+C in the program that calls COST. The WSAVE array must be
+C initialized by calling subroutine COSTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X For I=1,...,N
+C
+C X(I) = X(1)+(-1)**(I-1)*X(N)
+C
+C + the sum from K=2 to K=N-1
+C
+C 2*X(K)*COS((K-1)*(I-1)*PI/(N-1))
+C
+C A call of COST followed by another call of
+C COST will multiply the sequence X by 2*(N-1).
+C Hence COST is the unnormalized inverse
+C of itself.
+C
+C WSAVE contains initialization calculations which must not be
+C destroyed between calls of COST.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTF
+C***END PROLOGUE COST
+ DIMENSION X(1) ,WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT COST
+ NM1 = N-1
+ NP1 = N+1
+ NS2 = N/2
+ IF (N-2) 106,101,102
+ 101 X1H = X(1)+X(2)
+ X(2) = X(1)-X(2)
+ X(1) = X1H
+ RETURN
+ 102 IF (N .GT. 3) GO TO 103
+ X1P3 = X(1)+X(3)
+ TX2 = X(2)+X(2)
+ X(2) = X(1)-X(3)
+ X(1) = X1P3+TX2
+ X(3) = X1P3-TX2
+ RETURN
+ 103 C1 = X(1)-X(N)
+ X(1) = X(1)+X(N)
+ DO 104 K=2,NS2
+ KC = NP1-K
+ T1 = X(K)+X(KC)
+ T2 = X(K)-X(KC)
+ C1 = C1+WSAVE(KC)*T2
+ T2 = WSAVE(K)*T2
+ X(K) = T1-T2
+ X(KC) = T1+T2
+ 104 CONTINUE
+ MODN = MOD(N,2)
+ IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
+ CALL RFFTF (NM1,X,WSAVE(N+1))
+ XIM2 = X(2)
+ X(2) = C1
+ DO 105 I=4,N,2
+ XI = X(I)
+ X(I) = X(I-2)-X(I-1)
+ X(I-1) = XIM2
+ XIM2 = XI
+ 105 CONTINUE
+ IF (MODN .NE. 0) X(N) = XIM2
+ 106 RETURN
+ END
+ SUBROUTINE COSTI(N,WSAVE)
+C***BEGIN PROLOGUE COSTI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for COST.
+C***DESCRIPTION
+C
+C Subroutine COSTI initializes the array WSAVE which is used in
+C subroutine COST. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the sequence to be transformed. The method
+C is most efficient when N-1 is a product of small primes.
+C
+C Output Parameter
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15.
+C Different WSAVE arrays are required for different values
+C of N. The contents of WSAVE must not be changed between
+C calls of COST.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTI
+C***END PROLOGUE COSTI
+ DIMENSION WSAVE(1)
+ DATA PI /3.14159265358979/
+C***FIRST EXECUTABLE STATEMENT COSTI
+ IF (N .LE. 3) RETURN
+ NM1 = N-1
+ NP1 = N+1
+ NS2 = N/2
+ DT = PI/FLOAT(NM1)
+ FK = 0.
+ DO 101 K=2,NS2
+ KC = NP1-K
+ FK = FK+1.
+ WSAVE(K) = 2.*SIN(FK*DT)
+ WSAVE(KC) = 2.*COS(FK*DT)
+ 101 CONTINUE
+ CALL RFFTI (NM1,WSAVE(N+1))
+ RETURN
+ END
+ SUBROUTINE HW3CRT(XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS,
+ 1 BDYF,ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,MDIMF,F,PERTRB,
+ 2 IERROR,W)
+C***BEGIN PROLOGUE HW3CRT
+C***DATE WRITTEN 801001 (YYMMDD)
+C***REVISION DATE 830415 (YYMMDD)
+C***CATEGORY NO. I2B1A1A
+C***KEYWORDS CARTESIAN,ELLIPTIC,FISHPACK,HELMHOLTZ,PDE
+C***AUTHOR ADAMS, J., (NCAR)
+C SWARZTRAUBER, P., (NCAR)
+C SWEET, R., (NCAR)
+C***PURPOSE Subroutine HW3CRT solves the standard seven-point finite
+C difference approximation to the Helmholtz equation in
+C Cartesian coordinates.
+C***DESCRIPTION
+C
+C Subroutine HW3CRT solves the standard seven-point finite
+C difference approximation to the Helmholtz equation in Cartesian
+C coordinates:
+C
+C (d/dX)(dU/dX) + (d/dY)(dU/dY) + (d/dZ)(dU/dZ)
+C
+C + LAMBDA*U = F(X,Y,Z) .
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+C
+C * * * * * * * * Parameter Description * * * * * * * * * *
+C
+C
+C * * * * * * On Input * * * * * *
+C
+C XS,XF
+C The range of X, i.e. XS .LE. X .LE. XF .
+C XS must be less than XF.
+C
+C L
+C The number of panels into which the interval (XS,XF) is
+C subdivided. Hence, there will be L+1 grid points in the
+C X-direction given by X(I) = XS+(I-1)DX for I=1,2,...,L+1,
+C where DX = (XF-XS)/L is the panel width. L must be at
+C least 5 .
+C
+C LBDCND
+C Indicates the type of boundary conditions at X = XS and X = XF.
+C
+C = 0 If the solution is periodic in X, i.e.
+C U(L+I,J,K) = U(I,J,K).
+C = 1 If the solution is specified at X = XS and X = XF.
+C = 2 If the solution is specified at X = XS and the derivative
+C of the solution with respect to X is specified at X = XF.
+C = 3 If the derivative of the solution with respect to X is
+C specified at X = XS and X = XF.
+C = 4 If the derivative of the solution with respect to X is
+C specified at X = XS and the solution is specified at X=XF.
+C
+C BDXS
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to X at X = XS.
+C when LBDCND = 3 or 4,
+C
+C BDXS(J,K) = (d/dX)U(XS,Y(J),Z(K)), J=1,2,...,M+1,
+C K=1,2,...,N+1.
+C
+C When LBDCND has any other value, BDXS is a dummy variable.
+C BDXS must be dimensioned at least (M+1)*(N+1).
+C
+C BDXF
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to X at X = XF.
+C When LBDCND = 2 or 3,
+C
+C BDXF(J,K) = (d/dX)U(XF,Y(J),Z(K)), J=1,2,...,M+1,
+C K=1,2,...,N+1.
+C
+C When LBDCND has any other value, BDXF is a dummy variable.
+C BDXF must be dimensioned at least (M+1)*(N+1).
+C
+C YS,YF
+C The range of Y, i.e. YS .LE. Y .LE. YF.
+C YS must be less than YF.
+C
+C M
+C The number of panels into which the interval (YS,YF) is
+C subdivided. Hence, there will be M+1 grid points in the
+C Y-direction given by Y(J) = YS+(J-1)DY for J=1,2,...,M+1,
+C where DY = (YF-YS)/M is the panel width. M must be at
+C least 5 .
+C
+C MBDCND
+C Indicates the type of boundary conditions at Y = YS and Y = YF.
+C
+C = 0 If the solution is periodic in Y, i.e.
+C U(I,M+J,K) = U(I,J,K).
+C = 1 If the solution is specified at Y = YS and Y = YF.
+C = 2 If the solution is specified at Y = YS and the derivative
+C of the solution with respect to Y is specified at Y = YF.
+C = 3 If the derivative of the solution with respect to Y is
+C specified at Y = YS and Y = YF.
+C = 4 If the derivative of the solution with respect to Y is
+C specified at Y = YS and the solution is specified at Y=YF.
+C
+C BDYS
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to Y at Y = YS.
+C When MBDCND = 3 or 4,
+C
+C BDYS(I,K) = (d/dY)U(X(I),YS,Z(K)), I=1,2,...,L+1,
+C K=1,2,...,N+1.
+C
+C When MBDCND has any other value, BDYS is a dummy variable.
+C BDYS must be dimensioned at least (L+1)*(N+1).
+C
+C BDYF
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to Y at Y = YF.
+C When MBDCND = 2 or 3,
+C
+C BDYF(I,K) = (d/dY)U(X(I),YF,Z(K)), I=1,2,...,L+1,
+C K=1,2,...,N+1.
+C
+C When MBDCND has any other value, BDYF is a dummy variable.
+C BDYF must be dimensioned at least (L+1)*(N+1).
+C
+C ZS,ZF
+C The range of Z, i.e. ZS .LE. Z .LE. ZF.
+C ZS must be less than ZF.
+C
+C N
+C The number of panels into which the interval (ZS,ZF) is
+C subdivided. Hence, there will be N+1 grid points in the
+C Z-direction given by Z(K) = ZS+(K-1)DZ for K=1,2,...,N+1,
+C where DZ = (ZF-ZS)/N is the panel width. N must be at least 5.
+C
+C NBDCND
+C Indicates the type of boundary conditions at Z = ZS and Z = ZF.
+C
+C = 0 If the solution is periodic in Z, i.e.
+C U(I,J,N+K) = U(I,J,K).
+C = 1 If the solution is specified at Z = ZS and Z = ZF.
+C = 2 If the solution is specified at Z = ZS and the derivative
+C of the solution with respect to Z is specified at Z = ZF.
+C = 3 If the derivative of the solution with respect to Z is
+C specified at Z = ZS and Z = ZF.
+C = 4 If the derivative of the solution with respect to Z is
+C specified at Z = ZS and the solution is specified at Z=ZF.
+C
+C BDZS
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to Z at Z = ZS.
+C When NBDCND = 3 or 4,
+C
+C BDZS(I,J) = (d/dZ)U(X(I),Y(J),ZS), I=1,2,...,L+1,
+C J=1,2,...,M+1.
+C
+C When NBDCND has any other value, BDZS is a dummy variable.
+C BDZS must be dimensioned at least (L+1)*(M+1).
+C
+C BDZF
+C A two-dimensional array that specifies the values of the
+C derivative of the solution with respect to Z at Z = ZF.
+C When NBDCND = 2 or 3,
+C
+C BDZF(I,J) = (d/dZ)U(X(I),Y(J),ZF), I=1,2,...,L+1,
+C J=1,2,...,M+1.
+C
+C When NBDCND has any other value, BDZF is a dummy variable.
+C BDZF must be dimensioned at least (L+1)*(M+1).
+C
+C ELMBDA
+C The constant LAMBDA in the Helmholtz equation. If
+C LAMBDA .GT. 0, a solution may not exist. However, HW3CRT will
+C attempt to find a solution.
+C
+C F
+C A three-dimensional array that specifies the values of the
+C right side of the Helmholtz equation and boundary values (if
+C any). For I=2,3,...,L, J=2,3,...,M, and K=2,3,...,N
+C
+C F(I,J,K) = F(X(I),Y(J),Z(K)).
+C
+C On the boundaries F is defined by
+C
+C LBDCND F(1,J,K) F(L+1,J,K)
+C ------ --------------- ---------------
+C
+C 0 F(XS,Y(J),Z(K)) F(XS,Y(J),Z(K))
+C 1 U(XS,Y(J),Z(K)) U(XF,Y(J),Z(K))
+C 2 U(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) J=1,2,...,M+1
+C 3 F(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) K=1,2,...,N+1
+C 4 F(XS,Y(J),Z(K)) U(XF,Y(J),Z(K))
+C
+C MBDCND F(I,1,K) F(I,M+1,K)
+C ------ --------------- ---------------
+C
+C 0 F(X(I),YS,Z(K)) F(X(I),YS,Z(K))
+C 1 U(X(I),YS,Z(K)) U(X(I),YF,Z(K))
+C 2 U(X(I),YS,Z(K)) F(X(I),YF,Z(K)) I=1,2,...,L+1
+C 3 F(X(I),YS,Z(K)) F(X(I),YF,Z(K)) K=1,2,...,N+1
+C 4 F(X(I),YS,Z(K)) U(X(I),YF,Z(K))
+C
+C NBDCND F(I,J,1) F(I,J,N+1)
+C ------ --------------- ---------------
+C
+C 0 F(X(I),Y(J),ZS) F(X(I),Y(J),ZS)
+C 1 U(X(I),Y(J),ZS) U(X(I),Y(J),ZF)
+C 2 U(X(I),Y(J),ZS) F(X(I),Y(J),ZF) I=1,2,...,L+1
+C 3 F(X(I),Y(J),ZS) F(X(I),Y(J),ZF) J=1,2,...,M+1
+C 4 F(X(I),Y(J),ZS) U(X(I),Y(J),ZF)
+C
+C F must be dimensioned at least (L+1)*(M+1)*(N+1).
+C
+C NOTE:
+C
+C If the table calls for both the solution U and the right side F
+C on a boundary, then the solution must be specified.
+C
+C LDIMF
+C The row (or first) dimension of the arrays F,BDYS,BDYF,BDZS,
+C and BDZF as it appears in the program calling HW3CRT. this
+C parameter is used to specify the variable dimension of these
+C arrays. LDIMF must be at least L+1.
+C
+C MDIMF
+C The column (or second) dimension of the array F and the row (or
+C first) dimension of the arrays BDXS and BDXF as it appears in
+C the program calling HW3CRT. This parameter is used to specify
+C the variable dimension of these arrays.
+C MDIMF must be at least M+1.
+C
+C W
+C A one-dimensional array that must be provided by the user for
+C work space. The length of W must be at least 30 + L + M + 5*N
+C + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2))
+C
+C
+C * * * * * * On Output * * * * * *
+C
+C F
+C Contains the solution U(I,J,K) of the finite difference
+C approximation for the grid point (X(I),Y(J),Z(K)) for
+C I=1,2,...,L+1, J=1,2,...,M+1, and K=1,2,...,N+1.
+C
+C PERTRB
+C If a combination of periodic or derivative boundary conditions
+C is specified for a Poisson equation (LAMBDA = 0), a solution
+C may not exist. PERTRB is a constant, calculated and subtracted
+C from F, which ensures that a solution exists. pwscrt then
+C computes this solution, which is a least squares solution to
+C the original approximation. This solution is not unique and is
+C unnormalized. The value of PERTRB should be small compared to
+C the right side F. Otherwise, a solution is obtained to an
+C essentially different problem. This comparison should always
+C be made to insure that a meaningful solution has been obtained.
+C
+C IERROR
+C An error flag that indicates invalid input parameters. Except
+C for numbers 0 and 12, a solution is not attempted.
+C
+C = 0 No error
+C = 1 XS .GE. XF
+C = 2 L .LT. 5
+C = 3 LBDCND .LT. 0 .OR. LBDCND .GT. 4
+C = 4 YS .GE. YF
+C = 5 M .LT. 5
+C = 6 MBDCND .LT. 0 .OR. MBDCND .GT. 4
+C = 7 ZS .GE. ZF
+C = 8 N .LT. 5
+C = 9 NBDCND .LT. 0 .OR. NBDCND .GT. 4
+C = 10 LDIMF .LT. L+1
+C = 11 MDIMF .LT. M+1
+C = 12 LAMBDA .GT. 0
+C
+C Since this is the only means of indicating a possibly incorrect
+C call to HW3CRT, the user should test IERROR after the call.
+C***LONG DESCRIPTION
+C
+C * * * * * * * Program Specifications * * * * * * * * * * * *
+C
+C Dimension of BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1),
+C Arguments BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1),
+C F(LDIMF,MDIMF,N+1),W(see argument list)
+C
+C Latest December 1, 1978
+C Revision
+C
+C Subprograms HW3CRT,POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,
+C Required RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,
+C COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,
+C CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,
+C CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,
+C PIMACH
+C
+C Special NONE
+C Conditions
+C
+C Common NONE
+C Blocks
+C
+C I/O NONE
+C
+C Precision Single
+C
+C Specialist Roland Sweet
+C
+C Language FORTRAN
+C
+C History Written by Roland Sweet at NCAR in July,1977
+C
+C Algorithm This subroutine defines the finite difference
+C equations, incorporates boundary data, and
+C adjusts the right side of singular systems and
+C then calls POIS3D to solve the system.
+C
+C Space 7862(decimal) = 17300(octal) locations on the
+C Required NCAR Control Data 7600
+C
+C Timing and The execution time T on the NCAR Control Data
+C Accuracy 7600 for subroutine HW3CRT is roughly proportional
+C to L*M*N*(log2(L)+log2(M)+5), but also depends on
+C input parameters LBDCND and MBDCND. Some typical
+C values are listed in the table below.
+C The solution process employed results in a loss
+C of no more than three significant digits for L,M
+C and N as large as 32. More detailed information
+C about accuracy can be found in the documentation
+C for subroutine POIS3D which is the routine that
+C actually solves the finite difference equations.
+C
+C
+C L(=M=N) LBDCND(=MBDCND=NBDCND) T(MSECS)
+C ------- ---------------------- --------
+C
+C 16 0 300
+C 16 1 302
+C 16 3 348
+C 32 0 1925
+C 32 1 1929
+C 32 3 2109
+C
+C Portability American National Standards Institute FORTRAN.
+C The machine dependent constant PI is defined in
+C function PIMACH.
+C
+C Required COS,SIN,ATAN
+C Resident
+C Routines
+C
+C Reference NONE
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C***REFERENCES (NONE)
+C***ROUTINES CALLED POIS3D
+C***END PROLOGUE HW3CRT
+C
+C
+ DIMENSION BDXS(MDIMF,1) ,BDXF(MDIMF,1) ,
+ 1 BDYS(LDIMF,1) ,BDYF(LDIMF,1) ,
+ 2 BDZS(LDIMF,1) ,BDZF(LDIMF,1) ,
+ 3 F(LDIMF,MDIMF,1) ,W(1)
+C***FIRST EXECUTABLE STATEMENT HW3CRT
+ IERROR = 0
+ IF (XF .LE. XS) IERROR = 1
+ IF (L .LT. 5) IERROR = 2
+ IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3
+ IF (YF .LE. YS) IERROR = 4
+ IF (M .LT. 5) IERROR = 5
+ IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6
+ IF (ZF .LE. ZS) IERROR = 7
+ IF (N .LT. 5) IERROR = 8
+ IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9
+ IF (LDIMF .LT. L+1) IERROR = 10
+ IF (MDIMF .LT. M+1) IERROR = 11
+ IF (IERROR .NE. 0) GO TO 188
+ DY = (YF-YS)/FLOAT(M)
+ TWBYDY = 2./DY
+ C2 = 1./(DY**2)
+ MSTART = 1
+ MSTOP = M
+ MP1 = M+1
+ MP = MBDCND+1
+ GO TO (104,101,101,102,102),MP
+ 101 MSTART = 2
+ 102 GO TO (104,104,103,103,104),MP
+ 103 MSTOP = MP1
+ 104 MUNK = MSTOP-MSTART+1
+ DZ = (ZF-ZS)/FLOAT(N)
+ TWBYDZ = 2./DZ
+ NP = NBDCND+1
+ C3 = 1./(DZ**2)
+ NP1 = N+1
+ NSTART = 1
+ NSTOP = N
+ GO TO (108,105,105,106,106),NP
+ 105 NSTART = 2
+ 106 GO TO (108,108,107,107,108),NP
+ 107 NSTOP = NP1
+ 108 NUNK = NSTOP-NSTART+1
+ LP1 = L+1
+ DX = (XF-XS)/FLOAT(L)
+ C1 = 1./(DX**2)
+ TWBYDX = 2./DX
+ LP = LBDCND+1
+ LSTART = 1
+ LSTOP = L
+C
+C ENTER BOUNDARY DATA FOR X-BOUNDARIES.
+C
+ GO TO (122,109,109,112,112),LP
+ 109 LSTART = 2
+ DO 111 J=MSTART,MSTOP
+ DO 110 K=NSTART,NSTOP
+ F(2,J,K) = F(2,J,K)-C1*F(1,J,K)
+ 110 CONTINUE
+ 111 CONTINUE
+ GO TO 115
+ 112 DO 114 J=MSTART,MSTOP
+ DO 113 K=NSTART,NSTOP
+ F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K)
+ 113 CONTINUE
+ 114 CONTINUE
+ 115 GO TO (122,116,119,119,116),LP
+ 116 DO 118 J=MSTART,MSTOP
+ DO 117 K=NSTART,NSTOP
+ F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K)
+ 117 CONTINUE
+ 118 CONTINUE
+ GO TO 122
+ 119 LSTOP = LP1
+ DO 121 J=MSTART,MSTOP
+ DO 120 K=NSTART,NSTOP
+ F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K)
+ 120 CONTINUE
+ 121 CONTINUE
+ 122 LUNK = LSTOP-LSTART+1
+C
+C ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
+C
+ GO TO (136,123,123,126,126),MP
+ 123 DO 125 I=LSTART,LSTOP
+ DO 124 K=NSTART,NSTOP
+ F(I,2,K) = F(I,2,K)-C2*F(I,1,K)
+ 124 CONTINUE
+ 125 CONTINUE
+ GO TO 129
+ 126 DO 128 I=LSTART,LSTOP
+ DO 127 K=NSTART,NSTOP
+ F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K)
+ 127 CONTINUE
+ 128 CONTINUE
+ 129 GO TO (136,130,133,133,130),MP
+ 130 DO 132 I=LSTART,LSTOP
+ DO 131 K=NSTART,NSTOP
+ F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K)
+ 131 CONTINUE
+ 132 CONTINUE
+ GO TO 136
+ 133 DO 135 I=LSTART,LSTOP
+ DO 134 K=NSTART,NSTOP
+ F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K)
+ 134 CONTINUE
+ 135 CONTINUE
+ 136 CONTINUE
+C
+C ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
+C
+ GO TO (150,137,137,140,140),NP
+ 137 DO 139 I=LSTART,LSTOP
+ DO 138 J=MSTART,MSTOP
+ F(I,J,2) = F(I,J,2)-C3*F(I,J,1)
+ 138 CONTINUE
+ 139 CONTINUE
+ GO TO 143
+ 140 DO 142 I=LSTART,LSTOP
+ DO 141 J=MSTART,MSTOP
+ F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J)
+ 141 CONTINUE
+ 142 CONTINUE
+ 143 GO TO (150,144,147,147,144),NP
+ 144 DO 146 I=LSTART,LSTOP
+ DO 145 J=MSTART,MSTOP
+ F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1)
+ 145 CONTINUE
+ 146 CONTINUE
+ GO TO 150
+ 147 DO 149 I=LSTART,LSTOP
+ DO 148 J=MSTART,MSTOP
+ F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J)
+ 148 CONTINUE
+ 149 CONTINUE
+C
+C DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
+C
+ 150 CONTINUE
+ IWB = NUNK+1
+ IWC = IWB+NUNK
+ IWW = IWC+NUNK
+ DO 151 K=1,NUNK
+ I = IWC+K-1
+ W(K) = C3
+ W(I) = C3
+ I = IWB+K-1
+ W(I) = -2.*C3+ELMBDA
+ 151 CONTINUE
+ GO TO (155,155,153,152,152),NP
+ 152 W(IWC) = 2.*C3
+ 153 GO TO (155,155,154,154,155),NP
+ 154 W(IWB-1) = 2.*C3
+ 155 CONTINUE
+ PERTRB = 0.
+C
+C FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST.
+C
+ GO TO (156,172,172,156,172),LP
+ 156 GO TO (157,172,172,157,172),MP
+ 157 GO TO (158,172,172,158,172),NP
+ 158 IF (ELMBDA) 172,160,159
+ 159 IERROR = 12
+ GO TO 172
+ 160 CONTINUE
+ MSTPM1 = MSTOP-1
+ LSTPM1 = LSTOP-1
+ NSTPM1 = NSTOP-1
+ XLP = (2+LP)/3
+ YLP = (2+MP)/3
+ ZLP = (2+NP)/3
+ S1 = 0.
+ DO 164 K=2,NSTPM1
+ DO 162 J=2,MSTPM1
+ DO 161 I=2,LSTPM1
+ S1 = S1+F(I,J,K)
+ 161 CONTINUE
+ S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP
+ 162 CONTINUE
+ S2 = 0.
+ DO 163 I=2,LSTPM1
+ S2 = S2+F(I,1,K)+F(I,MSTOP,K)
+ 163 CONTINUE
+ S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/
+ 1 XLP)/YLP
+ S1 = S1+S2
+ 164 CONTINUE
+ S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+
+ 1 F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+
+ 2 F(LSTOP,MSTOP,NSTOP))/(XLP*YLP)
+ DO 166 J=2,MSTPM1
+ DO 165 I=2,LSTPM1
+ S = S+F(I,J,1)+F(I,J,NSTOP)
+ 165 CONTINUE
+ 166 CONTINUE
+ S2 = 0.
+ DO 167 I=2,LSTPM1
+ S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP)
+ 167 CONTINUE
+ S = S2/YLP+S
+ S2 = 0.
+ DO 168 J=2,MSTPM1
+ S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP)
+ 168 CONTINUE
+ S = S2/XLP+S
+ PERTRB = (S/ZLP+S1)/((FLOAT(LUNK+1)-XLP)*(FLOAT(MUNK+1)-YLP)*
+ 1 (FLOAT(NUNK+1)-ZLP))
+ DO 171 I=1,LUNK
+ DO 170 J=1,MUNK
+ DO 169 K=1,NUNK
+ F(I,J,K) = F(I,J,K)-PERTRB
+ 169 CONTINUE
+ 170 CONTINUE
+ 171 CONTINUE
+ 172 CONTINUE
+ NPEROD = 0
+ IF (NBDCND .EQ. 0) GO TO 173
+ NPEROD = 1
+ W(1) = 0.
+ W(IWW-1) = 0.
+ 173 CONTINUE
+ CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB),
+ 1 W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW))
+C
+C FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS.
+C
+ IF (LP .NE. 1) GO TO 180
+ IF (MP .NE. 1) GO TO 175
+ DO 174 K=NSTART,NSTOP
+ F(1,MP1,K) = F(1,1,K)
+ 174 CONTINUE
+ MSTOP = MP1
+ 175 IF (NP .NE. 1) GO TO 177
+ DO 176 J=MSTART,MSTOP
+ F(1,J,NP1) = F(1,J,1)
+ 176 CONTINUE
+ NSTOP = NP1
+ 177 DO 179 J=MSTART,MSTOP
+ DO 178 K=NSTART,NSTOP
+ F(LP1,J,K) = F(1,J,K)
+ 178 CONTINUE
+ 179 CONTINUE
+ 180 CONTINUE
+ IF (MP .NE. 1) GO TO 185
+ IF (NP .NE. 1) GO TO 182
+ DO 181 I=LSTART,LSTOP
+ F(I,1,NP1) = F(I,1,1)
+ 181 CONTINUE
+ NSTOP = NP1
+ 182 DO 184 I=LSTART,LSTOP
+ DO 183 K=NSTART,NSTOP
+ F(I,MP1,K) = F(I,1,K)
+ 183 CONTINUE
+ 184 CONTINUE
+ 185 CONTINUE
+ IF (NP .NE. 1) GO TO 188
+ DO 187 I=LSTART,LSTOP
+ DO 186 J=MSTART,MSTOP
+ F(I,J,NP1) = F(I,J,1)
+ 186 CONTINUE
+ 187 CONTINUE
+ 188 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSB(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+C***BEGIN PROLOGUE PASSB
+C***REFER TO CFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSB
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP)
+C***FIRST EXECUTABLE STATEMENT PASSB
+ IDOT = IDO/2
+ NT = IP*IDL1
+ IPP2 = IP+2
+ IPPH = (IP+1)/2
+ IDP = IP*IDO
+C
+ IF (IDO .LT. L1) GO TO 106
+ DO 103 J=2,IPPH
+ JC = IPP2-J
+ DO 102 K=1,L1
+CDIR$ IVDEP
+ DO 101 I=1,IDO
+ CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
+ CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
+ 101 CONTINUE
+ 102 CONTINUE
+ 103 CONTINUE
+ DO 105 K=1,L1
+CDIR$ IVDEP
+ DO 104 I=1,IDO
+ CH(I,K,1) = CC(I,1,K)
+ 104 CONTINUE
+ 105 CONTINUE
+ GO TO 112
+ 106 DO 109 J=2,IPPH
+ JC = IPP2-J
+ DO 108 I=1,IDO
+CDIR$ IVDEP
+ DO 107 K=1,L1
+ CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
+ CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
+ 107 CONTINUE
+ 108 CONTINUE
+ 109 CONTINUE
+ DO 111 I=1,IDO
+CDIR$ IVDEP
+ DO 110 K=1,L1
+ CH(I,K,1) = CC(I,1,K)
+ 110 CONTINUE
+ 111 CONTINUE
+ 112 IDL = 2-IDO
+ INC = 0
+ DO 116 L=2,IPPH
+ LC = IPP2-L
+ IDL = IDL+IDO
+CDIR$ IVDEP
+ DO 113 IK=1,IDL1
+ C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
+ C2(IK,LC) = WA(IDL)*CH2(IK,IP)
+ 113 CONTINUE
+ IDLJ = IDL
+ INC = INC+IDO
+ DO 115 J=3,IPPH
+ JC = IPP2-J
+ IDLJ = IDLJ+INC
+ IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
+ WAR = WA(IDLJ-1)
+ WAI = WA(IDLJ)
+CDIR$ IVDEP
+ DO 114 IK=1,IDL1
+ C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
+ C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
+ 114 CONTINUE
+ 115 CONTINUE
+ 116 CONTINUE
+ DO 118 J=2,IPPH
+CDIR$ IVDEP
+ DO 117 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
+ 117 CONTINUE
+ 118 CONTINUE
+ DO 120 J=2,IPPH
+ JC = IPP2-J
+CDIR$ IVDEP
+ DO 119 IK=2,IDL1,2
+ CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
+ CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
+ CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
+ CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
+ 119 CONTINUE
+ 120 CONTINUE
+ NAC = 1
+ IF (IDO .EQ. 2) RETURN
+ NAC = 0
+ DO 121 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 121 CONTINUE
+ DO 123 J=2,IP
+CDIR$ IVDEP
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)
+ C1(2,K,J) = CH(2,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+ IF (IDOT .GT. L1) GO TO 127
+ IDIJ = 0
+ DO 126 J=2,IP
+ IDIJ = IDIJ+2
+ DO 125 I=4,IDO,2
+ IDIJ = IDIJ+2
+CDIR$ IVDEP
+ DO 124 K=1,L1
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 124 CONTINUE
+ 125 CONTINUE
+ 126 CONTINUE
+ RETURN
+ 127 IDJ = 2-IDO
+ DO 130 J=2,IP
+ IDJ = IDJ+IDO
+ DO 129 K=1,L1
+ IDIJ = IDJ
+CDIR$ IVDEP
+ DO 128 I=4,IDO,2
+ IDIJ = IDIJ+2
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 128 CONTINUE
+ 129 CONTINUE
+ 130 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSB2(IDO,L1,CC,CH,WA1)
+C***BEGIN PROLOGUE PASSB2
+C***REFER TO CFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSB2
+ DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,
+ 1 WA1(1)
+C***FIRST EXECUTABLE STATEMENT PASSB2
+ IF (IDO .GT. 2) GO TO 102
+ DO 101 K=1,L1
+ CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
+ CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
+ CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
+ CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(I-1,2,K)
+ CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
+ TI2 = CC(I,1,K)-CC(I,2,K)
+ CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
+ CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(I-1,2,K)
+ CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
+ TI2 = CC(I,1,K)-CC(I,2,K)
+ CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
+ CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSB3(IDO,L1,CC,CH,WA1,WA2)
+C***BEGIN PROLOGUE PASSB3
+C***REFER TO CFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSB3
+ DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+C***FIRST EXECUTABLE STATEMENT PASSB3
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TR2 = CC(1,2,K)+CC(1,3,K)
+ CR2 = CC(1,1,K)+TAUR*TR2
+ CH(1,K,1) = CC(1,1,K)+TR2
+ TI2 = CC(2,2,K)+CC(2,3,K)
+ CI2 = CC(2,1,K)+TAUR*TI2
+ CH(2,K,1) = CC(2,1,K)+TI2
+ CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
+ CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
+ CH(1,K,2) = CR2-CI3
+ CH(1,K,3) = CR2+CI3
+ CH(2,K,2) = CI2+CR3
+ CH(2,K,3) = CI2-CR3
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TR2 = CC(I-1,2,K)+CC(I-1,3,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,2,K)+CC(I,3,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
+ CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
+ CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
+ CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
+ CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TR2 = CC(I-1,2,K)+CC(I-1,3,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,2,K)+CC(I,3,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
+ CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
+ CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
+ CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
+ CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSB4(IDO,L1,CC,CH,WA1,WA2,WA3)
+C***BEGIN PROLOGUE PASSB4
+C***REFER TO CFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSB4
+ DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+C***FIRST EXECUTABLE STATEMENT PASSB4
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TI1 = CC(2,1,K)-CC(2,3,K)
+ TI2 = CC(2,1,K)+CC(2,3,K)
+ TR4 = CC(2,4,K)-CC(2,2,K)
+ TI3 = CC(2,2,K)+CC(2,4,K)
+ TR1 = CC(1,1,K)-CC(1,3,K)
+ TR2 = CC(1,1,K)+CC(1,3,K)
+ TI4 = CC(1,2,K)-CC(1,4,K)
+ TR3 = CC(1,2,K)+CC(1,4,K)
+ CH(1,K,1) = TR2+TR3
+ CH(1,K,3) = TR2-TR3
+ CH(2,K,1) = TI2+TI3
+ CH(2,K,3) = TI2-TI3
+ CH(1,K,2) = TR1+TR4
+ CH(1,K,4) = TR1-TR4
+ CH(2,K,2) = TI1+TI4
+ CH(2,K,4) = TI1-TI4
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TI1 = CC(I,1,K)-CC(I,3,K)
+ TI2 = CC(I,1,K)+CC(I,3,K)
+ TI3 = CC(I,2,K)+CC(I,4,K)
+ TR4 = CC(I,4,K)-CC(I,2,K)
+ TR1 = CC(I-1,1,K)-CC(I-1,3,K)
+ TR2 = CC(I-1,1,K)+CC(I-1,3,K)
+ TI4 = CC(I-1,2,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,2,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1+TR4
+ CR4 = TR1-TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
+ CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
+ CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
+ CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
+ CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
+ CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TI1 = CC(I,1,K)-CC(I,3,K)
+ TI2 = CC(I,1,K)+CC(I,3,K)
+ TI3 = CC(I,2,K)+CC(I,4,K)
+ TR4 = CC(I,4,K)-CC(I,2,K)
+ TR1 = CC(I-1,1,K)-CC(I-1,3,K)
+ TR2 = CC(I-1,1,K)+CC(I-1,3,K)
+ TI4 = CC(I-1,2,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,2,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1+TR4
+ CR4 = TR1-TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
+ CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
+ CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
+ CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
+ CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
+ CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSF(NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+C***BEGIN PROLOGUE PASSF
+C***REFER TO CFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSF
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,WA(1) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP)
+C***FIRST EXECUTABLE STATEMENT PASSF
+ IDOT = IDO/2
+ NT = IP*IDL1
+ IPP2 = IP+2
+ IPPH = (IP+1)/2
+ IDP = IP*IDO
+C
+ IF (IDO .LT. L1) GO TO 106
+ DO 103 J=2,IPPH
+ JC = IPP2-J
+ DO 102 K=1,L1
+CDIR$ IVDEP
+ DO 101 I=1,IDO
+ CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
+ CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
+ 101 CONTINUE
+ 102 CONTINUE
+ 103 CONTINUE
+ DO 105 K=1,L1
+CDIR$ IVDEP
+ DO 104 I=1,IDO
+ CH(I,K,1) = CC(I,1,K)
+ 104 CONTINUE
+ 105 CONTINUE
+ GO TO 112
+ 106 DO 109 J=2,IPPH
+ JC = IPP2-J
+ DO 108 I=1,IDO
+CDIR$ IVDEP
+ DO 107 K=1,L1
+ CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
+ CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
+ 107 CONTINUE
+ 108 CONTINUE
+ 109 CONTINUE
+ DO 111 I=1,IDO
+CDIR$ IVDEP
+ DO 110 K=1,L1
+ CH(I,K,1) = CC(I,1,K)
+ 110 CONTINUE
+ 111 CONTINUE
+ 112 IDL = 2-IDO
+ INC = 0
+ DO 116 L=2,IPPH
+ LC = IPP2-L
+ IDL = IDL+IDO
+CDIR$ IVDEP
+ DO 113 IK=1,IDL1
+ C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
+ C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
+ 113 CONTINUE
+ IDLJ = IDL
+ INC = INC+IDO
+ DO 115 J=3,IPPH
+ JC = IPP2-J
+ IDLJ = IDLJ+INC
+ IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
+ WAR = WA(IDLJ-1)
+ WAI = WA(IDLJ)
+CDIR$ IVDEP
+ DO 114 IK=1,IDL1
+ C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
+ C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
+ 114 CONTINUE
+ 115 CONTINUE
+ 116 CONTINUE
+ DO 118 J=2,IPPH
+CDIR$ IVDEP
+ DO 117 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
+ 117 CONTINUE
+ 118 CONTINUE
+ DO 120 J=2,IPPH
+ JC = IPP2-J
+CDIR$ IVDEP
+ DO 119 IK=2,IDL1,2
+ CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
+ CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
+ CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
+ CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
+ 119 CONTINUE
+ 120 CONTINUE
+ NAC = 1
+ IF (IDO .EQ. 2) RETURN
+ NAC = 0
+CDIR$ IVDEP
+ DO 121 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 121 CONTINUE
+ DO 123 J=2,IP
+CDIR$ IVDEP
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)
+ C1(2,K,J) = CH(2,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+ IF (IDOT .GT. L1) GO TO 127
+ IDIJ = 0
+ DO 126 J=2,IP
+ IDIJ = IDIJ+2
+ DO 125 I=4,IDO,2
+ IDIJ = IDIJ+2
+CDIR$ IVDEP
+ DO 124 K=1,L1
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
+ 124 CONTINUE
+ 125 CONTINUE
+ 126 CONTINUE
+ RETURN
+ 127 IDJ = 2-IDO
+ DO 130 J=2,IP
+ IDJ = IDJ+IDO
+ DO 129 K=1,L1
+ IDIJ = IDJ
+CDIR$ IVDEP
+ DO 128 I=4,IDO,2
+ IDIJ = IDIJ+2
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
+ 128 CONTINUE
+ 129 CONTINUE
+ 130 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSF2(IDO,L1,CC,CH,WA1)
+C***BEGIN PROLOGUE PASSF2
+C***REFER TO CFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSF2
+ DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,
+ 1 WA1(1)
+C***FIRST EXECUTABLE STATEMENT PASSF2
+ IF (IDO .GT. 2) GO TO 102
+ DO 101 K=1,L1
+ CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
+ CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
+ CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
+ CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(I-1,2,K)
+ CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
+ TI2 = CC(I,1,K)-CC(I,2,K)
+ CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
+ CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(I-1,2,K)
+ CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
+ TI2 = CC(I,1,K)-CC(I,2,K)
+ CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
+ CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSF3(IDO,L1,CC,CH,WA1,WA2)
+C***BEGIN PROLOGUE PASSF3
+C***REFER TO CFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSF3
+ DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,-.866025403784439/
+C***FIRST EXECUTABLE STATEMENT PASSF3
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TR2 = CC(1,2,K)+CC(1,3,K)
+ CR2 = CC(1,1,K)+TAUR*TR2
+ CH(1,K,1) = CC(1,1,K)+TR2
+ TI2 = CC(2,2,K)+CC(2,3,K)
+ CI2 = CC(2,1,K)+TAUR*TI2
+ CH(2,K,1) = CC(2,1,K)+TI2
+ CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
+ CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
+ CH(1,K,2) = CR2-CI3
+ CH(1,K,3) = CR2+CI3
+ CH(2,K,2) = CI2+CR3
+ CH(2,K,3) = CI2-CR3
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TR2 = CC(I-1,2,K)+CC(I-1,3,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,2,K)+CC(I,3,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
+ CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
+ CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
+ CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
+ CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TR2 = CC(I-1,2,K)+CC(I-1,3,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,2,K)+CC(I,3,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
+ CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
+ CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
+ CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
+ CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSF4(IDO,L1,CC,CH,WA1,WA2,WA3)
+C***BEGIN PROLOGUE PASSF4
+C***REFER TO CFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSF4
+ DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+C***FIRST EXECUTABLE STATEMENT PASSF4
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TI1 = CC(2,1,K)-CC(2,3,K)
+ TI2 = CC(2,1,K)+CC(2,3,K)
+ TR4 = CC(2,2,K)-CC(2,4,K)
+ TI3 = CC(2,2,K)+CC(2,4,K)
+ TR1 = CC(1,1,K)-CC(1,3,K)
+ TR2 = CC(1,1,K)+CC(1,3,K)
+ TI4 = CC(1,4,K)-CC(1,2,K)
+ TR3 = CC(1,2,K)+CC(1,4,K)
+ CH(1,K,1) = TR2+TR3
+ CH(1,K,3) = TR2-TR3
+ CH(2,K,1) = TI2+TI3
+ CH(2,K,3) = TI2-TI3
+ CH(1,K,2) = TR1+TR4
+ CH(1,K,4) = TR1-TR4
+ CH(2,K,2) = TI1+TI4
+ CH(2,K,4) = TI1-TI4
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TI1 = CC(I,1,K)-CC(I,3,K)
+ TI2 = CC(I,1,K)+CC(I,3,K)
+ TI3 = CC(I,2,K)+CC(I,4,K)
+ TR4 = CC(I,2,K)-CC(I,4,K)
+ TR1 = CC(I-1,1,K)-CC(I-1,3,K)
+ TR2 = CC(I-1,1,K)+CC(I-1,3,K)
+ TI4 = CC(I-1,4,K)-CC(I-1,2,K)
+ TR3 = CC(I-1,2,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1+TR4
+ CR4 = TR1-TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
+ CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
+ CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
+ CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
+ CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
+ CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TI1 = CC(I,1,K)-CC(I,3,K)
+ TI2 = CC(I,1,K)+CC(I,3,K)
+ TI3 = CC(I,2,K)+CC(I,4,K)
+ TR4 = CC(I,2,K)-CC(I,4,K)
+ TR1 = CC(I-1,1,K)-CC(I-1,3,K)
+ TR2 = CC(I-1,1,K)+CC(I-1,3,K)
+ TI4 = CC(I-1,4,K)-CC(I-1,2,K)
+ TR3 = CC(I-1,2,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1+TR4
+ CR4 = TR1-TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
+ CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
+ CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
+ CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
+ CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
+ CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ FUNCTION PIMACH(DUM)
+C***BEGIN PROLOGUE PIMACH
+C***REFER TO HSTCSP,HSTSSP,HWSCSP
+C
+C This subprogram supplies the value of the constant PI correct to
+C machine precision where
+C
+C PI=3.1415926535897932384626433832795028841971693993751058209749446
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PIMACH
+C
+C***FIRST EXECUTABLE STATEMENT PIMACH
+ PIMACH = 3.14159265358979
+ RETURN
+ END
+ SUBROUTINE POIS3D(LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,
+ 1 MDIMF,F,IERROR,W)
+C***BEGIN PROLOGUE POIS3D
+C***DATE WRITTEN 801001 (YYMMDD)
+C***REVISION DATE 830415 (YYMMDD)
+C***CATEGORY NO. I2B4B
+C***KEYWORDS ELLIPTIC,FISHPACK,HELMHOLTZ,PDE,POISSON
+C***AUTHOR ADAMS, J., (NCAR)
+C SWARZTRAUBER, P., (NCAR)
+C SWEET, R., (NCAR)
+C***PURPOSE This subroutine solves three-dimensional block
+C tridiagonal linear systems arising from finite
+C difference approximations to three-dimensional
+C Poisson equations using the Fourier transform
+C package SCLRFFTPAK written by Paul Swarztrauber.
+C***DESCRIPTION
+C
+C Subroutine POIS3D solves the linear system of equations
+C
+C C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K))
+C + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K))
+C + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K)
+C
+C for I=1,2,...,L , J=1,2,...,M , and K=1,2,...,N .
+C
+C The indices K-1 and K+1 are evaluated modulo N, i.e.
+C X(I,J,0) = X(I,J,N) and X(I,J,N+1) = X(I,J,1). The unknowns
+C X(0,J,K), X(L+1,J,K), X(I,0,K), and X(I,M+1,K) are assumed to take
+C on certain prescribed values described below.
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C
+C
+C * * * * * * * * Parameter Description * * * * * * * * * *
+C
+C
+C * * * * * * On Input * * * * * *
+C
+C LPEROD Indicates the values that X(0,J,K) and X(L+1,J,K) are
+C assumed to have.
+C
+C = 0 If X(0,J,K) = X(L,J,K) and X(L+1,J,K) = X(1,J,K).
+C = 1 If X(0,J,K) = X(L+1,J,K) = 0.
+C = 2 If X(0,J,K) = 0 and X(L+1,J,K) = X(L-1,J,K).
+C = 3 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = X(L-1,J,K).
+C = 4 If X(0,J,K) = X(2,J,K) and X(L+1,J,K) = 0.
+C
+C L The number of unknowns in the I-direction. L must be at
+C least 3.
+C
+C C1 The real constant that appears in the above equation.
+C
+C MPEROD Indicates the values that X(I,0,K) and X(I,M+1,K) are
+C assumed to have.
+C
+C = 0 If X(I,0,K) = X(I,M,K) and X(I,M+1,K) = X(I,1,K).
+C = 1 If X(I,0,K) = X(I,M+1,K) = 0.
+C = 2 If X(I,0,K) = 0 and X(I,M+1,K) = X(I,M-1,K).
+C = 3 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = X(I,M-1,K).
+C = 4 If X(I,0,K) = X(I,2,K) and X(I,M+1,K) = 0.
+C
+C M The number of unknowns in the J-direction. M must be at
+C least 3.
+C
+C C2 The real constant which appears in the above equation.
+C
+C NPEROD = 0 If A(1) and C(N) are not zero.
+C = 1 If A(1) = C(N) = 0.
+C
+C N The number of unknowns in the K-direction. N must be at
+C least 3.
+C
+C
+C A,B,C One-dimensional arrays of length N that specify the
+C coefficients in the linear equations given above.
+C
+C If NPEROD = 0 the array elements must not depend upon the
+C index K, but must be constant. Specifically,the
+C subroutine checks the following condition
+C
+C A(K) = C(1)
+C C(K) = C(1)
+C B(K) = B(1)
+C
+C for K=1,2,...,N.
+C
+C LDIMF The row (or first) dimension of the three-dimensional
+C array F as it appears in the program calling POIS3D.
+C This parameter is used to specify the variable dimension
+C of F. LDIMF must be at least L.
+C
+C MDIMF The column (or second) dimension of the three-dimensional
+C array F as it appears in the program calling POIS3D.
+C This parameter is used to specify the variable dimension
+C of F. MDIMF must be at least M.
+C
+C F A three-dimensional array that specifies the values of
+C the right side of the linear system of equations given
+C above. F must be dimensioned at least L x M x N.
+C
+C W A one-dimensional array that must be provided by the
+C user for work space. The length of W must be at least
+C 30 + L + M + 2*N + MAX(L,M,N) +
+C 7*(INT((L+1)/2) + INT((M+1)/2)).
+C
+C
+C * * * * * * On Output * * * * * *
+C
+C F Contains the solution X.
+C
+C IERROR An error flag that indicates invalid input parameters.
+C Except for number zero, a solution is not attempted.
+C = 0 No error
+C = 1 If LPEROD .LT. 0 or .GT. 4
+C = 2 If L .LT. 3
+C = 3 If MPEROD .LT. 0 or .GT. 4
+C = 4 If M .LT. 3
+C = 5 If NPEROD .LT. 0 or .GT. 1
+C = 6 If N .LT. 3
+C = 7 If LDIMF .LT. L
+C = 8 If MDIMF .LT. M
+C = 9 If A(K) .NE. C(1) or C(K) .NE. C(1) or B(I) .NE.B(1)
+C for some K=1,2,...,N.
+C = 10 If NPEROD = 1 and A(1) .NE. 0 or C(N) .NE. 0
+C
+C Since this is the only means of indicating a possibly
+C incorrect call to POIS3D, the user should test IERROR
+C after the call.
+C***LONG DESCRIPTION
+C
+C * * * * * * * Program Specifications * * * * * * * * * * * *
+C
+C Dimension of A(N),B(N),C(N),F(LDIMF,MDIMF,N),
+C Arguments W(see argument list)
+C
+C Latest December 1, 1978
+C Revision
+C
+C Subprograms POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,RFFTB,
+C Required RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1
+C COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1,
+C CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF,
+C CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH,
+C
+C Special NONE
+C Conditions
+C
+C Common NONE
+C Blocks
+C
+C I/O NONE
+C
+C Precision Single
+C
+C Specialist Roland Sweet
+C
+C Language FORTRAN
+C
+C History Written by Roland Sweet at NCAR in July,1977
+C
+C Algorithm This subroutine solves three-dimensional block
+C tridiagonal linear systems arising from finite
+C difference approximations to three-dimensional
+C Poisson equations using the Fourier transform
+C package SCLRFFTPAK written by Paul Swarztrauber.
+C
+C Space 6561(decimal) = 14641(octal) locations on the
+C Required NCAR Control Data 7600
+C
+C Timing and The execution time T on the NCAR Control Data
+C Accuracy 7600 for subroutine POIS3D is roughly proportional
+C to L*M*N*(log2(L)+log2(M)+5), but also depends on
+C input parameters LPEROD and MPEROD. Some typical
+C values are listed in the table below when NPEROD=0.
+C To measure the accuracy of the algorithm a
+C uniform random number generator was used to create
+C a solution array X for the system given in the
+C 'PURPOSE' with
+C
+C A(K) = C(K) = -0.5*B(K) = 1, K=1,2,...,N
+C
+C and, when NPEROD = 1
+C
+C A(1) = C(N) = 0
+C A(N) = C(1) = 2.
+C
+C The solution X was substituted into the given sys-
+C tem and, using double precision, a right side Y was
+C computed. Using this array Y subroutine POIS3D was
+C called to produce an approximate solution Z. Then
+C the relative error, defined as
+C
+C E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K)))
+C
+C where the two maxima are taken over I=1,2,...,L,
+C J=1,2,...,M and K=1,2,...,N, was computed. The
+C value of E is given in the table below for some
+C typical values of L,M and N.
+C
+C
+C L(=M=N) LPEROD MPEROD T(MSECS) E
+C ------ ------ ------ -------- ------
+C
+C 16 0 0 272 1.E-13
+C 15 1 1 287 4.E-13
+C 17 3 3 338 2.E-13
+C 32 0 0 1755 2.E-13
+C 31 1 1 1894 2.E-12
+C 33 3 3 2042 7.E-13
+C
+C
+C Portability American National Standards Institute FORTRAN.
+C The machine dependent constant PI is defined in
+C function PIMACH.
+C
+C Required COS,SIN,ATAN
+C Resident
+C Routines
+C
+C Reference NONE
+C
+C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C***REFERENCES (NONE)
+C***ROUTINES CALLED POS3D1
+C***END PROLOGUE POIS3D
+C
+C
+ DIMENSION A(1) ,B(1) ,C(1) ,
+ 1 F(LDIMF,MDIMF,1) ,W(1) ,SAVE(6)
+C***FIRST EXECUTABLE STATEMENT POIS3D
+ LP = LPEROD+1
+ MP = MPEROD+1
+ NP = NPEROD+1
+C
+C CHECK FOR INVALID INPUT.
+C
+ IERROR = 0
+ IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
+ IF (L .LT. 3) IERROR = 2
+ IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
+ IF (M .LT. 3) IERROR = 4
+ IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
+ IF (N .LT. 3) IERROR = 6
+ IF (LDIMF .LT. L) IERROR = 7
+ IF (MDIMF .LT. M) IERROR = 8
+ IF (NP .NE. 1) GO TO 103
+ DO 101 K=1,N
+ IF (A(K) .NE. C(1)) GO TO 102
+ IF (C(K) .NE. C(1)) GO TO 102
+ IF (B(K) .NE. B(1)) GO TO 102
+ 101 CONTINUE
+ GO TO 104
+ 102 IERROR = 9
+ 103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
+ 104 IF (IERROR .NE. 0) GO TO 122
+ IWYRT = L+1
+ IWT = IWYRT+M
+ IWD = IWT+MAX0(L,M,N)+1
+ IWBB = IWD+N
+ IWX = IWBB+N
+ IWY = IWX+7*((L+1)/2)+15
+ GO TO (105,114),NP
+C
+C REORDER UNKNOWNS WHEN NPEROD = 0.
+C
+ 105 NH = (N+1)/2
+ NHM1 = NH-1
+ NODD = 1
+ IF (2*NH .EQ. N) NODD = 2
+ DO 111 I=1,L
+ DO 110 J=1,M
+ DO 106 K=1,NHM1
+ NHPK = NH+K
+ NHMK = NH-K
+ W(K) = F(I,J,NHMK)-F(I,J,NHPK)
+ W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
+ 106 CONTINUE
+ W(NH) = 2.*F(I,J,NH)
+ GO TO (108,107),NODD
+ 107 W(N) = 2.*F(I,J,N)
+ 108 DO 109 K=1,N
+ F(I,J,K) = W(K)
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 CONTINUE
+ SAVE(1) = C(NHM1)
+ SAVE(2) = A(NH)
+ SAVE(3) = C(NH)
+ SAVE(4) = B(NHM1)
+ SAVE(5) = B(N)
+ SAVE(6) = A(N)
+ C(NHM1) = 0.
+ A(NH) = 0.
+ C(NH) = 2.*C(NH)
+ GO TO (112,113),NODD
+ 112 B(NHM1) = B(NHM1)-A(NH-1)
+ B(N) = B(N)+A(N)
+ GO TO 114
+ 113 A(N) = C(NH)
+ 114 CONTINUE
+ CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
+ 1 W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
+ GO TO (115,122),NP
+ 115 DO 121 I=1,L
+ DO 120 J=1,M
+ DO 116 K=1,NHM1
+ NHMK = NH-K
+ NHPK = NH+K
+ W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
+ W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
+ 116 CONTINUE
+ W(NH) = .5*F(I,J,NH)
+ GO TO (118,117),NODD
+ 117 W(N) = .5*F(I,J,N)
+ 118 DO 119 K=1,N
+ F(I,J,K) = W(K)
+ 119 CONTINUE
+ 120 CONTINUE
+ 121 CONTINUE
+ C(NHM1) = SAVE(1)
+ A(NH) = SAVE(2)
+ C(NH) = SAVE(3)
+ B(NHM1) = SAVE(4)
+ B(N) = SAVE(5)
+ A(N) = SAVE(6)
+ 122 CONTINUE
+ RETURN
+ END
+ SUBROUTINE POS3D1(LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,XRT,YRT,T,D,WX,
+ 1 WY,C1,C2,BB)
+C***BEGIN PROLOGUE POS3D1
+C***REFER TO POIS3D
+C***ROUTINES CALLED COSQB,COSQF,COSQI,COST,COSTI,PIMACH,RFFTB,RFFTF,
+C RFFTI,SINQB,SINQF,SINQI,SINT,SINTI,TRID
+C***END PROLOGUE POS3D1
+ DIMENSION A(1) ,B(1) ,C(1) ,
+ 1 F(LDIMF,MDIMF,1) ,XRT(1) ,YRT(1) ,
+ 2 T(1) ,D(1) ,WX(1) ,WY(1) ,
+ 3 BB(1)
+C***FIRST EXECUTABLE STATEMENT POS3D1
+ PI = PIMACH(DUM)
+ LR = L
+ MR = M
+ NR = N
+C
+C GENERATE TRANSFORM ROOTS
+C
+ LRDEL = ((LP-1)*(LP-3)*(LP-5))/3
+ SCALX = LR+LRDEL
+ DX = PI/(2.*SCALX)
+ GO TO (108,103,101,102,101),LP
+ 101 DI = 0.5
+ SCALX = 2.*SCALX
+ GO TO 104
+ 102 DI = 1.0
+ GO TO 104
+ 103 DI = 0.0
+ 104 DO 105 I=1,LR
+ XRT(I) = -4.*C1*(SIN((FLOAT(I)-DI)*DX))**2
+ 105 CONTINUE
+ SCALX = 2.*SCALX
+ GO TO (112,106,110,107,111),LP
+ 106 CALL SINTI (LR,WX)
+ GO TO 112
+ 107 CALL COSTI (LR,WX)
+ GO TO 112
+ 108 XRT(1) = 0.
+ XRT(LR) = -4.*C1
+ DO 109 I=3,LR,2
+ XRT(I-1) = -4.*C1*(SIN(FLOAT((I-1))*DX))**2
+ XRT(I) = XRT(I-1)
+ 109 CONTINUE
+ CALL RFFTI (LR,WX)
+ GO TO 112
+ 110 CALL SINQI (LR,WX)
+ GO TO 112
+ 111 CALL COSQI (LR,WX)
+ 112 CONTINUE
+ MRDEL = ((MP-1)*(MP-3)*(MP-5))/3
+ SCALY = MR+MRDEL
+ DY = PI/(2.*SCALY)
+ GO TO (120,115,113,114,113),MP
+ 113 DJ = 0.5
+ SCALY = 2.*SCALY
+ GO TO 116
+ 114 DJ = 1.0
+ GO TO 116
+ 115 DJ = 0.0
+ 116 DO 117 J=1,MR
+ YRT(J) = -4.*C2*(SIN((FLOAT(J)-DJ)*DY))**2
+ 117 CONTINUE
+ SCALY = 2.*SCALY
+ GO TO (124,118,122,119,123),MP
+ 118 CALL SINTI (MR,WY)
+ GO TO 124
+ 119 CALL COSTI (MR,WY)
+ GO TO 124
+ 120 YRT(1) = 0.
+ YRT(MR) = -4.*C2
+ DO 121 J=3,MR,2
+ YRT(J-1) = -4.*C2*(SIN(FLOAT((J-1))*DY))**2
+ YRT(J) = YRT(J-1)
+ 121 CONTINUE
+ CALL RFFTI (MR,WY)
+ GO TO 124
+ 122 CALL SINQI (MR,WY)
+ GO TO 124
+ 123 CALL COSQI (MR,WY)
+ 124 CONTINUE
+ IFWRD = 1
+ IS = 1
+ 125 CONTINUE
+C
+C TRANSFORM X
+C
+ DO 141 J=1,MR
+ DO 140 K=1,NR
+ DO 126 I=1,LR
+ T(I) = F(I,J,K)
+ 126 CONTINUE
+ GO TO (127,130,131,134,135),LP
+ 127 GO TO (128,129),IFWRD
+ 128 CALL RFFTF (LR,T,WX)
+ GO TO 138
+ 129 CALL RFFTB (LR,T,WX)
+ GO TO 138
+ 130 CALL SINT (LR,T,WX)
+ GO TO 138
+ 131 GO TO (132,133),IFWRD
+ 132 CALL SINQF (LR,T,WX)
+ GO TO 138
+ 133 CALL SINQB (LR,T,WX)
+ GO TO 138
+ 134 CALL COST (LR,T,WX)
+ GO TO 138
+ 135 GO TO (136,137),IFWRD
+ 136 CALL COSQF (LR,T,WX)
+ GO TO 138
+ 137 CALL COSQB (LR,T,WX)
+ 138 CONTINUE
+ DO 139 I=1,LR
+ F(I,J,K) = T(I)
+ 139 CONTINUE
+ 140 CONTINUE
+ 141 CONTINUE
+ GO TO (142,164),IFWRD
+C
+C TRANSFORM Y
+C
+ 142 CONTINUE
+ DO 158 I=1,LR
+ DO 157 K=1,NR
+ DO 143 J=1,MR
+ T(J) = F(I,J,K)
+ 143 CONTINUE
+ GO TO (144,147,148,151,152),MP
+ 144 GO TO (145,146),IFWRD
+ 145 CALL RFFTF (MR,T,WY)
+ GO TO 155
+ 146 CALL RFFTB (MR,T,WY)
+ GO TO 155
+ 147 CALL SINT (MR,T,WY)
+ GO TO 155
+ 148 GO TO (149,150),IFWRD
+ 149 CALL SINQF (MR,T,WY)
+ GO TO 155
+ 150 CALL SINQB (MR,T,WY)
+ GO TO 155
+ 151 CALL COST (MR,T,WY)
+ GO TO 155
+ 152 GO TO (153,154),IFWRD
+ 153 CALL COSQF (MR,T,WY)
+ GO TO 155
+ 154 CALL COSQB (MR,T,WY)
+ 155 CONTINUE
+ DO 156 J=1,MR
+ F(I,J,K) = T(J)
+ 156 CONTINUE
+ 157 CONTINUE
+ 158 CONTINUE
+ GO TO (159,125),IFWRD
+ 159 CONTINUE
+C
+C SOLVE TRIDIAGONAL SYSTEMS IN Z
+C
+ DO 163 I=1,LR
+ DO 162 J=1,MR
+ DO 160 K=1,NR
+ BB(K) = B(K)+XRT(I)+YRT(J)
+ T(K) = F(I,J,K)
+ 160 CONTINUE
+ CALL TRID (NR,A,BB,C,T,D)
+ DO 161 K=1,NR
+ F(I,J,K) = T(K)
+ 161 CONTINUE
+ 162 CONTINUE
+ 163 CONTINUE
+ IFWRD = 2
+ IS = -1
+ GO TO 142
+ 164 CONTINUE
+ DO 167 I=1,LR
+ DO 166 J=1,MR
+ DO 165 K=1,NR
+ F(I,J,K) = F(I,J,K)/(SCALX*SCALY)
+ 165 CONTINUE
+ 166 CONTINUE
+ 167 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RADB2(IDO,L1,CC,CH,WA1)
+C***BEGIN PROLOGUE RADB2
+C***REFER TO RFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADB2
+ DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,
+ 1 WA1(1)
+C***FIRST EXECUTABLE STATEMENT RADB2
+ DO 101 K=1,L1
+ CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
+ CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 108
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
+ CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
+ TI2 = CC(I,1,K)+CC(IC,2,K)
+ CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
+ CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ GO TO 111
+ 108 DO 110 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 109 K=1,L1
+ CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
+ TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
+ CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
+ TI2 = CC(I,1,K)+CC(IC,2,K)
+ CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
+ CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
+ CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
+ 106 CONTINUE
+ 107 RETURN
+ END
+ SUBROUTINE RADB3(IDO,L1,CC,CH,WA1,WA2)
+C***BEGIN PROLOGUE RADB3
+C***REFER TO RFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADB3
+ DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+C***FIRST EXECUTABLE STATEMENT RADB3
+ DO 101 K=1,L1
+ TR2 = CC(IDO,2,K)+CC(IDO,2,K)
+ CR2 = CC(1,1,K)+TAUR*TR2
+ CH(1,K,1) = CC(1,1,K)+TR2
+ CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
+ CH(1,K,2) = CR2-CI3
+ CH(1,K,3) = CR2+CI3
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 104
+ DO 103 K=1,L1
+CDIR$ IVDEP
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
+ CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ 104 DO 106 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 105 K=1,L1
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CR2 = CC(I-1,1,K)+TAUR*TR2
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ CI2 = CC(I,1,K)+TAUR*TI2
+ CH(I,K,1) = CC(I,1,K)+TI2
+ CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
+ CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
+ DR2 = CR2-CI3
+ DR3 = CR2+CI3
+ DI2 = CI2+CR3
+ DI3 = CI2-CR3
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ 105 CONTINUE
+ 106 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RADB4(IDO,L1,CC,CH,WA1,WA2,WA3)
+C***BEGIN PROLOGUE RADB4
+C***REFER TO RFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADB4
+ DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+ DATA SQRT2 /1.414213562373095/
+C***FIRST EXECUTABLE STATEMENT RADB4
+ DO 101 K=1,L1
+ TR1 = CC(1,1,K)-CC(IDO,4,K)
+ TR2 = CC(1,1,K)+CC(IDO,4,K)
+ TR3 = CC(IDO,2,K)+CC(IDO,2,K)
+ TR4 = CC(1,3,K)+CC(1,3,K)
+ CH(1,K,1) = TR2+TR3
+ CH(1,K,2) = TR1-TR4
+ CH(1,K,3) = TR2-TR3
+ CH(1,K,4) = TR1+TR4
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 108
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TI1 = CC(I,1,K)+CC(IC,4,K)
+ TI2 = CC(I,1,K)-CC(IC,4,K)
+ TI3 = CC(I,3,K)-CC(IC,2,K)
+ TR4 = CC(I,3,K)+CC(IC,2,K)
+ TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
+ TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
+ TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1-TR4
+ CR4 = TR1+TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
+ CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
+ CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
+ CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
+ CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
+ CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
+ 103 CONTINUE
+ 104 CONTINUE
+ GO TO 111
+ 108 DO 110 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 109 K=1,L1
+ TI1 = CC(I,1,K)+CC(IC,4,K)
+ TI2 = CC(I,1,K)-CC(IC,4,K)
+ TI3 = CC(I,3,K)-CC(IC,2,K)
+ TR4 = CC(I,3,K)+CC(IC,2,K)
+ TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
+ TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
+ TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
+ CH(I-1,K,1) = TR2+TR3
+ CR3 = TR2-TR3
+ CH(I,K,1) = TI2+TI3
+ CI3 = TI2-TI3
+ CR2 = TR1-TR4
+ CR4 = TR1+TR4
+ CI2 = TI1+TI4
+ CI4 = TI1-TI4
+ CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
+ CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
+ CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
+ CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
+ CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
+ CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ TI1 = CC(1,2,K)+CC(1,4,K)
+ TI2 = CC(1,4,K)-CC(1,2,K)
+ TR1 = CC(IDO,1,K)-CC(IDO,3,K)
+ TR2 = CC(IDO,1,K)+CC(IDO,3,K)
+ CH(IDO,K,1) = TR2+TR2
+ CH(IDO,K,2) = SQRT2*(TR1-TI1)
+ CH(IDO,K,3) = TI2+TI2
+ CH(IDO,K,4) = -SQRT2*(TR1+TI1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+ SUBROUTINE RADB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+C***BEGIN PROLOGUE RADB5
+C***REFER TO RFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADB5
+ DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+C***FIRST EXECUTABLE STATEMENT RADB5
+ DO 101 K=1,L1
+ TI5 = CC(1,3,K)+CC(1,3,K)
+ TI4 = CC(1,5,K)+CC(1,5,K)
+ TR2 = CC(IDO,2,K)+CC(IDO,2,K)
+ TR3 = CC(IDO,4,K)+CC(IDO,4,K)
+ CH(1,K,1) = CC(1,1,K)+TR2+TR3
+ CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
+ CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
+ CI5 = TI11*TI5+TI12*TI4
+ CI4 = TI12*TI5-TI11*TI4
+ CH(1,K,2) = CR2-CI5
+ CH(1,K,3) = CR3-CI4
+ CH(1,K,4) = CR3+CI4
+ CH(1,K,5) = CR2+CI5
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 104
+ DO 103 K=1,L1
+CDIR$ IVDEP
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ TI5 = CC(I,3,K)+CC(IC,2,K)
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ TI4 = CC(I,5,K)+CC(IC,4,K)
+ TI3 = CC(I,5,K)-CC(IC,4,K)
+ TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
+ TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
+ CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
+ CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
+ CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ 104 DO 106 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 105 K=1,L1
+ TI5 = CC(I,3,K)+CC(IC,2,K)
+ TI2 = CC(I,3,K)-CC(IC,2,K)
+ TI4 = CC(I,5,K)+CC(IC,4,K)
+ TI3 = CC(I,5,K)-CC(IC,4,K)
+ TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
+ TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
+ TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
+ TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
+ CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
+ CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
+ CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
+ CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
+ CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
+ CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
+ CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
+ 105 CONTINUE
+ 106 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RADBG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+C***BEGIN PROLOGUE RADBG
+C***REFER TO RFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADBG
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP) ,WA(1)
+ DATA TPI/6.28318530717959/
+C***FIRST EXECUTABLE STATEMENT RADBG
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IPP2 = IP+2
+ IPPH = (IP+1)/2
+ IF (IDO .LT. L1) GO TO 103
+ DO 102 K=1,L1
+ DO 101 I=1,IDO
+ CH(I,K,1) = CC(I,1,K)
+ 101 CONTINUE
+ 102 CONTINUE
+ GO TO 106
+ 103 DO 105 I=1,IDO
+ DO 104 K=1,L1
+ CH(I,K,1) = CC(I,1,K)
+ 104 CONTINUE
+ 105 CONTINUE
+ 106 DO 108 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 107 K=1,L1
+ CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
+ CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
+ 107 CONTINUE
+ 108 CONTINUE
+ IF (IDO .EQ. 1) GO TO 116
+ IF (NBD .LT. L1) GO TO 112
+ DO 111 J=2,IPPH
+ JC = IPP2-J
+ DO 110 K=1,L1
+CDIR$ IVDEP
+ DO 109 I=3,IDO,2
+ IC = IDP2-I
+ CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
+ CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
+ CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
+ CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 CONTINUE
+ GO TO 116
+ 112 DO 115 J=2,IPPH
+ JC = IPP2-J
+CDIR$ IVDEP
+ DO 114 I=3,IDO,2
+ IC = IDP2-I
+ DO 113 K=1,L1
+ CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
+ CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
+ CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
+ CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
+ 113 CONTINUE
+ 114 CONTINUE
+ 115 CONTINUE
+ 116 AR1 = 1.
+ AI1 = 0.
+ DO 120 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 117 IK=1,IDL1
+ C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
+ C2(IK,LC) = AI1*CH2(IK,IP)
+ 117 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+ DO 119 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 118 IK=1,IDL1
+ C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
+ C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
+ 118 CONTINUE
+ 119 CONTINUE
+ 120 CONTINUE
+ DO 122 J=2,IPPH
+ DO 121 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
+ 121 CONTINUE
+ 122 CONTINUE
+ DO 124 J=2,IPPH
+ JC = IPP2-J
+ DO 123 K=1,L1
+ CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
+ CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
+ 123 CONTINUE
+ 124 CONTINUE
+ IF (IDO .EQ. 1) GO TO 132
+ IF (NBD .LT. L1) GO TO 128
+ DO 127 J=2,IPPH
+ JC = IPP2-J
+ DO 126 K=1,L1
+CDIR$ IVDEP
+ DO 125 I=3,IDO,2
+ CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
+ CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
+ CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
+ CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ GO TO 132
+ 128 DO 131 J=2,IPPH
+ JC = IPP2-J
+ DO 130 I=3,IDO,2
+ DO 129 K=1,L1
+ CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
+ CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
+ CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
+ CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
+ 129 CONTINUE
+ 130 CONTINUE
+ 131 CONTINUE
+ 132 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ DO 133 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 133 CONTINUE
+ DO 135 J=2,IP
+ DO 134 K=1,L1
+ C1(1,K,J) = CH(1,K,J)
+ 134 CONTINUE
+ 135 CONTINUE
+ IF (NBD .GT. L1) GO TO 139
+ IS = -IDO
+ DO 138 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 137 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 136 K=1,L1
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 136 CONTINUE
+ 137 CONTINUE
+ 138 CONTINUE
+ GO TO 143
+ 139 IS = -IDO
+ DO 142 J=2,IP
+ IS = IS+IDO
+ DO 141 K=1,L1
+ IDIJ = IS
+CDIR$ IVDEP
+ DO 140 I=3,IDO,2
+ IDIJ = IDIJ+2
+ C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
+ C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
+ 140 CONTINUE
+ 141 CONTINUE
+ 142 CONTINUE
+ 143 RETURN
+ END
+ SUBROUTINE RADF2(IDO,L1,CC,CH,WA1)
+C***BEGIN PROLOGUE RADF2
+C***REFER TO RFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADF2
+ DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) ,
+ 1 WA1(1)
+C***FIRST EXECUTABLE STATEMENT RADF2
+ DO 101 K=1,L1
+ CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 108
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CH(I,1,K) = CC(I,K,1)+TI2
+ CH(IC,2,K) = TI2-CC(I,K,1)
+ CH(I-1,1,K) = CC(I-1,K,1)+TR2
+ CH(IC-1,2,K) = CC(I-1,K,1)-TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ GO TO 111
+ 108 DO 110 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 109 K=1,L1
+ TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CH(I,1,K) = CC(I,K,1)+TI2
+ CH(IC,2,K) = TI2-CC(I,K,1)
+ CH(I-1,1,K) = CC(I-1,K,1)+TR2
+ CH(IC-1,2,K) = CC(I-1,K,1)-TR2
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(1,2,K) = -CC(IDO,K,2)
+ CH(IDO,1,K) = CC(IDO,K,1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+ SUBROUTINE RADF3(IDO,L1,CC,CH,WA1,WA2)
+C***BEGIN PROLOGUE RADF3
+C***REFER TO RFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADF3
+ DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) ,
+ 1 WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+C***FIRST EXECUTABLE STATEMENT RADF3
+ DO 101 K=1,L1
+ CR2 = CC(1,K,2)+CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2
+ CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
+ CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 104
+ DO 103 K=1,L1
+CDIR$ IVDEP
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR2 = DR2+DR3
+ CI2 = DI2+DI3
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2
+ CH(I,1,K) = CC(I,K,1)+CI2
+ TR2 = CC(I-1,K,1)+TAUR*CR2
+ TI2 = CC(I,K,1)+TAUR*CI2
+ TR3 = TAUI*(DI2-DI3)
+ TI3 = TAUI*(DR3-DR2)
+ CH(I-1,3,K) = TR2+TR3
+ CH(IC-1,2,K) = TR2-TR3
+ CH(I,3,K) = TI2+TI3
+ CH(IC,2,K) = TI3-TI2
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ 104 DO 106 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 105 K=1,L1
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR2 = DR2+DR3
+ CI2 = DI2+DI3
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2
+ CH(I,1,K) = CC(I,K,1)+CI2
+ TR2 = CC(I-1,K,1)+TAUR*CR2
+ TI2 = CC(I,K,1)+TAUR*CI2
+ TR3 = TAUI*(DI2-DI3)
+ TI3 = TAUI*(DR3-DR2)
+ CH(I-1,3,K) = TR2+TR3
+ CH(IC-1,2,K) = TR2-TR3
+ CH(I,3,K) = TI2+TI3
+ CH(IC,2,K) = TI3-TI2
+ 105 CONTINUE
+ 106 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RADF4(IDO,L1,CC,CH,WA1,WA2,WA3)
+C***BEGIN PROLOGUE RADF4
+C***REFER TO RFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADF4
+ DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1)
+ DATA HSQT2 /.7071067811865475/
+C***FIRST EXECUTABLE STATEMENT RADF4
+ DO 101 K=1,L1
+ TR1 = CC(1,K,2)+CC(1,K,4)
+ TR2 = CC(1,K,1)+CC(1,K,3)
+ CH(1,1,K) = TR1+TR2
+ CH(IDO,4,K) = TR2-TR1
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
+ CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2) 107,105,102
+ 102 IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 111
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ TR1 = CR2+CR4
+ TR4 = CR4-CR2
+ TI1 = CI2+CI4
+ TI4 = CI2-CI4
+ TI2 = CC(I,K,1)+CI3
+ TI3 = CC(I,K,1)-CI3
+ TR2 = CC(I-1,K,1)+CR3
+ TR3 = CC(I-1,K,1)-CR3
+ CH(I-1,1,K) = TR1+TR2
+ CH(IC-1,4,K) = TR2-TR1
+ CH(I,1,K) = TI1+TI2
+ CH(IC,4,K) = TI1-TI2
+ CH(I-1,3,K) = TI4+TR3
+ CH(IC-1,2,K) = TR3-TI4
+ CH(I,3,K) = TR4+TI3
+ CH(IC,2,K) = TR4-TI3
+ 103 CONTINUE
+ 104 CONTINUE
+ GO TO 110
+ 111 DO 109 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 108 K=1,L1
+ CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ TR1 = CR2+CR4
+ TR4 = CR4-CR2
+ TI1 = CI2+CI4
+ TI4 = CI2-CI4
+ TI2 = CC(I,K,1)+CI3
+ TI3 = CC(I,K,1)-CI3
+ TR2 = CC(I-1,K,1)+CR3
+ TR3 = CC(I-1,K,1)-CR3
+ CH(I-1,1,K) = TR1+TR2
+ CH(IC-1,4,K) = TR2-TR1
+ CH(I,1,K) = TI1+TI2
+ CH(IC,4,K) = TI1-TI2
+ CH(I-1,3,K) = TI4+TR3
+ CH(IC-1,2,K) = TR3-TI4
+ CH(I,3,K) = TR4+TI3
+ CH(IC,2,K) = TR4-TI3
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
+ TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
+ CH(IDO,1,K) = TR1+CC(IDO,K,1)
+ CH(IDO,3,K) = CC(IDO,K,1)-TR1
+ CH(1,2,K) = TI1-CC(IDO,K,3)
+ CH(1,4,K) = TI1+CC(IDO,K,3)
+ 106 CONTINUE
+ 107 RETURN
+ END
+ SUBROUTINE RADF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+C***BEGIN PROLOGUE RADF5
+C***REFER TO RFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADF5
+ DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+C***FIRST EXECUTABLE STATEMENT RADF5
+ DO 101 K=1,L1
+ CR2 = CC(1,K,5)+CC(1,K,2)
+ CI5 = CC(1,K,5)-CC(1,K,2)
+ CR3 = CC(1,K,4)+CC(1,K,3)
+ CI4 = CC(1,K,4)-CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2+CR3
+ CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
+ CH(1,3,K) = TI11*CI5+TI12*CI4
+ CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
+ CH(1,5,K) = TI12*CI5-TI11*CI4
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ IF((IDO-1)/2.LT.L1) GO TO 104
+ DO 103 K=1,L1
+CDIR$ IVDEP
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
+ DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
+ CR2 = DR2+DR5
+ CI5 = DR5-DR2
+ CR5 = DI2-DI5
+ CI2 = DI2+DI5
+ CR3 = DR3+DR4
+ CI4 = DR4-DR3
+ CR4 = DI3-DI4
+ CI3 = DI3+DI4
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
+ CH(I,1,K) = CC(I,K,1)+CI2+CI3
+ TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
+ TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
+ TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
+ TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
+ TR5 = TI11*CR5+TI12*CR4
+ TI5 = TI11*CI5+TI12*CI4
+ TR4 = TI12*CR5-TI11*CR4
+ TI4 = TI12*CI5-TI11*CI4
+ CH(I-1,3,K) = TR2+TR5
+ CH(IC-1,2,K) = TR2-TR5
+ CH(I,3,K) = TI2+TI5
+ CH(IC,2,K) = TI5-TI2
+ CH(I-1,5,K) = TR3+TR4
+ CH(IC-1,4,K) = TR3-TR4
+ CH(I,5,K) = TI3+TI4
+ CH(IC,4,K) = TI4-TI3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ 104 DO 106 I=3,IDO,2
+ IC = IDP2-I
+CDIR$ IVDEP
+ DO 105 K=1,L1
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
+ DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
+ CR2 = DR2+DR5
+ CI5 = DR5-DR2
+ CR5 = DI2-DI5
+ CI2 = DI2+DI5
+ CR3 = DR3+DR4
+ CI4 = DR4-DR3
+ CR4 = DI3-DI4
+ CI3 = DI3+DI4
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
+ CH(I,1,K) = CC(I,K,1)+CI2+CI3
+ TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
+ TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
+ TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
+ TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
+ TR5 = TI11*CR5+TI12*CR4
+ TI5 = TI11*CI5+TI12*CI4
+ TR4 = TI12*CR5-TI11*CR4
+ TI4 = TI12*CI5-TI11*CI4
+ CH(I-1,3,K) = TR2+TR5
+ CH(IC-1,2,K) = TR2-TR5
+ CH(I,3,K) = TI2+TI5
+ CH(IC,2,K) = TI5-TI2
+ CH(I-1,5,K) = TR3+TR4
+ CH(IC-1,4,K) = TR3-TR4
+ CH(I,5,K) = TI3+TI4
+ CH(IC,4,K) = TI4-TI3
+ 105 CONTINUE
+ 106 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RADFG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+C***BEGIN PROLOGUE RADFG
+C***REFER TO RFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RADFG
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP) ,WA(1)
+ DATA TPI/6.28318530717959/
+C***FIRST EXECUTABLE STATEMENT RADFG
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IPPH = (IP+1)/2
+ IPP2 = IP+2
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IF (IDO .EQ. 1) GO TO 119
+ DO 101 IK=1,IDL1
+ CH2(IK,1) = C2(IK,1)
+ 101 CONTINUE
+ DO 103 J=2,IP
+ DO 102 K=1,L1
+ CH(1,K,J) = C1(1,K,J)
+ 102 CONTINUE
+ 103 CONTINUE
+ IF (NBD .GT. L1) GO TO 107
+ IS = -IDO
+ DO 106 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 105 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 104 K=1,L1
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 104 CONTINUE
+ 105 CONTINUE
+ 106 CONTINUE
+ GO TO 111
+ 107 IS = -IDO
+ DO 110 J=2,IP
+ IS = IS+IDO
+ DO 109 K=1,L1
+ IDIJ = IS
+CDIR$ IVDEP
+ DO 108 I=3,IDO,2
+ IDIJ = IDIJ+2
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (NBD .LT. L1) GO TO 115
+ DO 114 J=2,IPPH
+ JC = IPP2-J
+ DO 113 K=1,L1
+CDIR$ IVDEP
+ DO 112 I=3,IDO,2
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 112 CONTINUE
+ 113 CONTINUE
+ 114 CONTINUE
+ GO TO 121
+ 115 DO 118 J=2,IPPH
+ JC = IPP2-J
+ DO 117 I=3,IDO,2
+ DO 116 K=1,L1
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 116 CONTINUE
+ 117 CONTINUE
+ 118 CONTINUE
+ GO TO 121
+ 119 DO 120 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 120 CONTINUE
+ 121 DO 123 J=2,IPPH
+ JC = IPP2-J
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
+ C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+C
+ AR1 = 1.
+ AI1 = 0.
+ DO 127 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 124 IK=1,IDL1
+ CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
+ CH2(IK,LC) = AI1*C2(IK,IP)
+ 124 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+ DO 126 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 125 IK=1,IDL1
+ CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
+ CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ DO 129 J=2,IPPH
+ DO 128 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+C2(IK,J)
+ 128 CONTINUE
+ 129 CONTINUE
+C
+ IF (IDO .LT. L1) GO TO 132
+ DO 131 K=1,L1
+ DO 130 I=1,IDO
+ CC(I,1,K) = CH(I,K,1)
+ 130 CONTINUE
+ 131 CONTINUE
+ GO TO 135
+ 132 DO 134 I=1,IDO
+ DO 133 K=1,L1
+ CC(I,1,K) = CH(I,K,1)
+ 133 CONTINUE
+ 134 CONTINUE
+ 135 DO 137 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 136 K=1,L1
+ CC(IDO,J2-2,K) = CH(1,K,J)
+ CC(1,J2-1,K) = CH(1,K,JC)
+ 136 CONTINUE
+ 137 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IF (NBD .LT. L1) GO TO 141
+ DO 140 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 139 K=1,L1
+CDIR$ IVDEP
+ DO 138 I=3,IDO,2
+ IC = IDP2-I
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 138 CONTINUE
+ 139 CONTINUE
+ 140 CONTINUE
+ RETURN
+ 141 DO 144 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 143 I=3,IDO,2
+ IC = IDP2-I
+ DO 142 K=1,L1
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 142 CONTINUE
+ 143 CONTINUE
+ 144 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RFFTB(N,R,WSAVE)
+C***BEGIN PROLOGUE RFFTB
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A1
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Backward transform of a real coefficient array.
+C***DESCRIPTION
+C
+C Subroutine RFFTB computes the real perodic sequence from its
+C Fourier coefficients (Fourier synthesis). The transform is defined
+C below at output parameter R.
+C
+C Input Parameters
+C
+C N the length of the array R to be transformed. The method
+C is most efficient when N is a product of small primes.
+C N may change so long as different work arrays are provided.
+C
+C R a real array of length N which contains the sequence
+C to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 2*N+15
+C in the program that calls RFFTB. The WSAVE array must be
+C initialized by calling subroutine RFFTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C The same WSAVE array can be used by RFFTF and RFFTB.
+C
+C
+C Output Parameters
+C
+C R For N even and For I = 1,...,N
+C
+C R(I) = R(1)+(-1)**(I-1)*R(N)
+C
+C plus the sum from K=2 to K=N/2 of
+C
+C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
+C
+C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
+C
+C For N odd and For I = 1,...,N
+C
+C R(I) = R(1) plus the sum from K=2 to K=(N+1)/2 of
+C
+C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
+C
+C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
+C
+C ***** Note:
+C This transform is unnormalized since a call of RFFTF
+C followed by a call of RFFTB will multiply the input
+C sequence by N.
+C
+C WSAVE contains results which must not be destroyed between
+C calls of RFFTB or RFFTF.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTB1
+C***END PROLOGUE RFFTB
+ DIMENSION R(1) ,WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT RFFTB
+ IF (N .EQ. 1) RETURN
+ CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+ SUBROUTINE RFFTB1(N,C,CH,WA,IFAC)
+C***BEGIN PROLOGUE RFFTB1
+C***REFER TO RFFTB
+C***ROUTINES CALLED RADB2,RADB3,RADB4,RADB5,RADBG
+C***END PROLOGUE RFFTB1
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)
+C***FIRST EXECUTABLE STATEMENT RFFTB1
+ NF = IFAC(2)
+ NA = 0
+ L1 = 1
+ IW = 1
+ DO 116 K1=1,NF
+ IP = IFAC(K1+2)
+ L2 = IP*L1
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IF (IP .NE. 4) GO TO 103
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA .NE. 0) GO TO 101
+ CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 102
+ 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ 102 NA = 1-NA
+ GO TO 115
+ 103 IF (IP .NE. 2) GO TO 106
+ IF (NA .NE. 0) GO TO 104
+ CALL RADB2 (IDO,L1,C,CH,WA(IW))
+ GO TO 105
+ 104 CALL RADB2 (IDO,L1,CH,C,WA(IW))
+ 105 NA = 1-NA
+ GO TO 115
+ 106 IF (IP .NE. 3) GO TO 109
+ IX2 = IW+IDO
+ IF (NA .NE. 0) GO TO 107
+ CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 108
+ 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ 108 NA = 1-NA
+ GO TO 115
+ 109 IF (IP .NE. 5) GO TO 112
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA .NE. 0) GO TO 110
+ CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 111
+ 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ 111 NA = 1-NA
+ GO TO 115
+ 112 IF (NA .NE. 0) GO TO 113
+ CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ GO TO 114
+ 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ 114 IF (IDO .EQ. 1) NA = 1-NA
+ 115 L1 = L2
+ IW = IW+(IP-1)*IDO
+ 116 CONTINUE
+ IF (NA .EQ. 0) RETURN
+ DO 117 I=1,N
+ C(I) = CH(I)
+ 117 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RFFTF(N,R,WSAVE)
+C***BEGIN PROLOGUE RFFTF
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A1
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Forward transform of a real, periodic sequence.
+C***DESCRIPTION
+C
+C Subroutine RFFTF computes the Fourier coefficients of a real
+C perodic sequence (Fourier analysis). The transform is defined
+C below at output parameter R.
+C
+C Input Parameters
+C
+C N the length of the array R to be transformed. The method
+C is most efficient when N is a product of small primes.
+C N may change so long as different work arrays are provided
+C
+C R a real array of length N which contains the sequence
+C to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 2*N+15
+C in the program that calls RFFTF. The WSAVE array must be
+C initialized by calling subroutine RFFTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C the same WSAVE array can be used by RFFTF and RFFTB.
+C
+C
+C Output Parameters
+C
+C R R(1) = the sum from I=1 to I=N of R(I)
+C
+C If N is even set L = N/2; if N is odd set L = (N+1)/2
+C
+C then for K = 2,...,L
+C
+C R(2*K-2) = the sum from I = 1 to I = N of
+C
+C R(I)*COS((K-1)*(I-1)*2*PI/N)
+C
+C R(2*K-1) = the sum from I = 1 to I = N of
+C
+C -R(I)*SIN((K-1)*(I-1)*2*PI/N)
+C
+C If N is even
+C
+C R(N) = the sum from I = 1 to I = N of
+C
+C (-1)**(I-1)*R(I)
+C
+C ***** Note:
+C This transform is unnormalized since a call of RFFTF
+C followed by a call of RFFTB will multiply the input
+C sequence by N.
+C
+C WSAVE contains results which must not be destroyed between
+C calls of RFFTF or RFFTB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTF1
+C***END PROLOGUE RFFTF
+ DIMENSION R(1) ,WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT RFFTF
+ IF (N .EQ. 1) RETURN
+ CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+ SUBROUTINE RFFTF1(N,C,CH,WA,IFAC)
+C***BEGIN PROLOGUE RFFTF1
+C***REFER TO RFFTF
+C***ROUTINES CALLED RADF2,RADF3,RADF4,RADF5,RADFG
+C***END PROLOGUE RFFTF1
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1)
+C***FIRST EXECUTABLE STATEMENT RFFTF1
+ NF = IFAC(2)
+ NA = 1
+ L2 = N
+ IW = N
+ DO 111 K1=1,NF
+ KH = NF-K1
+ IP = IFAC(KH+3)
+ L1 = L2/IP
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IW = IW-(IP-1)*IDO
+ NA = 1-NA
+ IF (IP .NE. 4) GO TO 102
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA .NE. 0) GO TO 101
+ CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 102 IF (IP .NE. 2) GO TO 104
+ IF (NA .NE. 0) GO TO 103
+ CALL RADF2 (IDO,L1,C,CH,WA(IW))
+ GO TO 110
+ 103 CALL RADF2 (IDO,L1,CH,C,WA(IW))
+ GO TO 110
+ 104 IF (IP .NE. 3) GO TO 106
+ IX2 = IW+IDO
+ IF (NA .NE. 0) GO TO 105
+ CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 110
+ 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ GO TO 110
+ 106 IF (IP .NE. 5) GO TO 108
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA .NE. 0) GO TO 107
+ CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 108 IF (IDO .EQ. 1) NA = 1-NA
+ IF (NA .NE. 0) GO TO 109
+ CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ NA = 1
+ GO TO 110
+ 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ NA = 0
+ 110 L2 = L1
+ 111 CONTINUE
+ IF (NA .EQ. 1) RETURN
+ DO 112 I=1,N
+ C(I) = CH(I)
+ 112 CONTINUE
+ RETURN
+ END
+ SUBROUTINE RFFTI(N,WSAVE)
+C***BEGIN PROLOGUE RFFTI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A1
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for RFFTF and RFFTB.
+C***DESCRIPTION
+C
+C Subroutine RFFTI initializes the array WSAVE which is used in
+C both RFFTF and RFFTB. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the sequence to be transformed.
+C
+C Output Parameter
+C
+C WSAVE a work array which must be dimensioned at least 2*N+15.
+C The same work array can be used for both RFFTF and RFFTB
+C as long as N remains unchanged. Different WSAVE arrays
+C are required for different values of N. The contents of
+C WSAVE must not be changed between calls of RFFTF or RFFTB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTI1
+C***END PROLOGUE RFFTI
+ DIMENSION WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT RFFTI
+ IF (N .EQ. 1) RETURN
+ CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+ SUBROUTINE RFFTI1(N,WA,IFAC)
+C***BEGIN PROLOGUE RFFTI1
+C***REFER TO RFFTI
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE RFFTI1
+ DIMENSION WA(1) ,IFAC(1) ,NTRYH(4)
+ DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
+C***FIRST EXECUTABLE STATEMENT RFFTI1
+ NL = N
+ NF = 0
+ J = 0
+ 101 J = J+1
+ IF (J-4) 102,102,103
+ 102 NTRY = NTRYH(J)
+ GO TO 104
+ 103 NTRY = NTRY+2
+ 104 NQ = NL/NTRY
+ NR = NL-NTRY*NQ
+ IF (NR) 101,105,101
+ 105 NF = NF+1
+ IFAC(NF+2) = NTRY
+ NL = NQ
+ IF (NTRY .NE. 2) GO TO 107
+ IF (NF .EQ. 1) GO TO 107
+ DO 106 I=2,NF
+ IB = NF-I+2
+ IFAC(IB+2) = IFAC(IB+1)
+ 106 CONTINUE
+ IFAC(3) = 2
+ 107 IF (NL .NE. 1) GO TO 104
+ IFAC(1) = N
+ IFAC(2) = NF
+ TPI = 6.28318530717959
+ ARGH = TPI/FLOAT(N)
+ IS = 0
+ NFM1 = NF-1
+ L1 = 1
+ IF (NFM1 .EQ. 0) RETURN
+ DO 110 K1=1,NFM1
+ IP = IFAC(K1+2)
+ LD = 0
+ L2 = L1*IP
+ IDO = N/L2
+ IPM = IP-1
+ DO 109 J=1,IPM
+ LD = LD+L1
+ I = IS
+ ARGLD = FLOAT(LD)*ARGH
+ FI = 0.
+ DO 108 II=3,IDO,2
+ I = I+2
+ FI = FI+1.
+ ARG = FI*ARGLD
+ WA(I-1) = COS(ARG)
+ WA(I) = SIN(ARG)
+ 108 CONTINUE
+ IS = IS+IDO
+ 109 CONTINUE
+ L1 = L2
+ 110 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SINQB(N,X,WSAVE)
+C***BEGIN PROLOGUE SINQB
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Unnormalized inverse of SINQF.
+C***DESCRIPTION
+C
+C Subroutine SINQB computes the fast Fourier transform of quarter
+C wave data. That is, SINQB computes a sequence from its
+C representation in terms of a sine series with odd wave numbers.
+C the transform is defined below at output parameter X.
+C
+C SINQF is the unnormalized inverse of SINQB since a call of SINQB
+C followed by a call of SINQF will multiply the input sequence X
+C by 4*N.
+C
+C The array WSAVE which is used by subroutine SINQB must be
+C initialized by calling subroutine SINQI(N,WSAVE).
+C
+C
+C Input Parameters
+C
+C N the length of the array X to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15
+C in the program that calls SINQB. The WSAVE array must be
+C initialized by calling subroutine SINQI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X for I=1,...,N
+C
+C X(I)= the sum from K=1 to K=N of
+C
+C 4*X(K)*SIN((2k-1)*I*PI/(2*N))
+C
+C a call of SINQB followed by a call of
+C SINQF will multiply the sequence X by 4*N.
+C Therefore SINQF is the unnormalized inverse
+C of SINQB.
+C
+C WSAVE contains initialization calculations which must not
+C be destroyed between calls of SINQB or SINQF.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED COSQB
+C***END PROLOGUE SINQB
+ DIMENSION X(1) ,WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT SINQB
+ IF (N .GT. 1) GO TO 101
+ X(1) = 4.*X(1)
+ RETURN
+ 101 NS2 = N/2
+ DO 102 K=2,N,2
+ X(K) = -X(K)
+ 102 CONTINUE
+ CALL COSQB (N,X,WSAVE)
+ DO 103 K=1,NS2
+ KC = N-K
+ XHOLD = X(K)
+ X(K) = X(KC+1)
+ X(KC+1) = XHOLD
+ 103 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SINQF(N,X,WSAVE)
+C***BEGIN PROLOGUE SINQF
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Forward sine transform with odd wave numbers.
+C***DESCRIPTION
+C
+C Subroutine SINQF computes the fast Fourier transform of quarter
+C wave data. That is, SINQF computes the coefficients in a sine
+C series representation with only odd wave numbers. The transform
+C is defined below at output parameter X.
+C
+C SINQB is the unnormalized inverse of SINQF since a call of SINQF
+C followed by a call of SINQB will multiply the input sequence X
+C by 4*N.
+C
+C The array WSAVE which is used by subroutine SINQF must be
+C initialized by calling subroutine SINQI(N,WSAVE).
+C
+C
+C Input Parameters
+C
+C N the length of the array X to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15
+C in the program that calls SINQF. The WSAVE array must be
+C initialized by calling subroutine SINQI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X For I=1,...,N
+C
+C X(I) = (-1)**(I-1)*X(N)
+C
+C + the sum from K=1 to K=N-1 of
+C
+C 2*X(K)*SIN((2*I-1)*K*PI/(2*N))
+C
+C A call of SINQF followed by a call of
+C SINQB will multiply the sequence X by 4*N.
+C Therefore SINQB is the unnormalized inverse
+C of SINQF.
+C
+C WSAVE contains initialization calculations which must not
+C be destroyed between calls of SINQF or SINQB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED COSQF
+C***END PROLOGUE SINQF
+ DIMENSION X(1) ,WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT SINQF
+ IF (N .EQ. 1) RETURN
+ NS2 = N/2
+ DO 101 K=1,NS2
+ KC = N-K
+ XHOLD = X(K)
+ X(K) = X(KC+1)
+ X(KC+1) = XHOLD
+ 101 CONTINUE
+ CALL COSQF (N,X,WSAVE)
+ DO 102 K=2,N,2
+ X(K) = -X(K)
+ 102 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SINQI(N,WSAVE)
+C***BEGIN PROLOGUE SINQI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for SINQF and SINQB.
+C***DESCRIPTION
+C
+C Subroutine SINQI initializes the array WSAVE which is used in
+C both SINQF and SINQB. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the sequence to be transformed. The method
+C is most efficient when N is a product of small primes.
+C
+C Output Parameter
+C
+C WSAVE a work array which must be dimensioned at least 3*N+15.
+C The same work array can be used for both SINQF and SINQB
+C as long as N remains unchanged. Different WSAVE arrays
+C are required for different values of N. The contents of
+C WSAVE must not be changed between calls of SINQF or SINQB.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED COSQI
+C***END PROLOGUE SINQI
+ DIMENSION WSAVE(1)
+C***FIRST EXECUTABLE STATEMENT SINQI
+ CALL COSQI (N,WSAVE)
+ RETURN
+ END
+ SUBROUTINE SINT(N,X,WSAVE)
+C***BEGIN PROLOGUE SINT
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Sine transform of a real, odd sequence.
+C***DESCRIPTION
+C
+C Subroutine SINT computes the discrete Fourier sine transform
+C of an odd sequence X(I). The transform is defined below at
+C output parameter X.
+C
+C SINT is the unnormalized inverse of itself since a call of SINT
+C followed by another call of SINT will multiply the input sequence
+C X by 2*(N+1).
+C
+C The array WSAVE which is used by subroutine SINT must be
+C initialized by calling subroutine SINTI(N,WSAVE).
+C
+C Input Parameters
+C
+C N the length of the sequence to be transformed. The method
+C is most efficient when N+1 is the product of small primes.
+C
+C X an array which contains the sequence to be transformed
+C
+C
+C WSAVE a work array with dimension at least INT(3.5*N+16)
+C in the program that calls SINT. The WSAVE array must be
+C initialized by calling subroutine SINTI(N,WSAVE), and a
+C different WSAVE array must be used for each different
+C value of N. This initialization does not have to be
+C repeated so long as N remains unchanged. Thus subsequent
+C transforms can be obtained faster than the first.
+C
+C Output Parameters
+C
+C X for I=1,...,N
+C
+C X(I)= the sum from k=1 to k=N
+C
+C 2*X(K)*SIN(K*I*PI/(N+1))
+C
+C A call of SINT followed by another call of
+C SINT will multiply the sequence X by 2*(N+1).
+C Hence SINT is the unnormalized inverse
+C of itself.
+C
+C WSAVE contains initialization calculations which must not be
+C destroyed between calls of SINT.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTF
+C***END PROLOGUE SINT
+ DIMENSION X(1) ,WSAVE(1)
+ DATA SQRT3 /1.73205080756888/
+C***FIRST EXECUTABLE STATEMENT SINT
+ IF (N-2) 101,102,103
+ 101 X(1) = X(1)+X(1)
+ RETURN
+ 102 XH = SQRT3*(X(1)+X(2))
+ X(2) = SQRT3*(X(1)-X(2))
+ X(1) = XH
+ RETURN
+ 103 NP1 = N+1
+ NS2 = N/2
+ WSAVE(1) = 0.
+ KW = NP1
+ DO 104 K=1,NS2
+1 KW = KW+1
+ KC = NP1-K
+ T1 = X(K)-X(KC)
+ T2 = WSAVE(KW)*(X(K)+X(KC))
+ WSAVE(K+1) = T1+T2
+ WSAVE(KC+1) = T2-T1
+ 104 CONTINUE
+ MODN = MOD(N,2)
+ IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1)
+ NF = NP1+NS2+1
+ CALL RFFTF (NP1,WSAVE,WSAVE(NF))
+ X(1) = .5*WSAVE(1)
+ DO 105 I=3,N,2
+ X(I-1) = -WSAVE(I)
+ X(I) = X(I-2)+WSAVE(I-1)
+ 105 CONTINUE
+ IF (MODN .NE. 0) RETURN
+ X(N) = -WSAVE(N+1)
+ RETURN
+ END
+ SUBROUTINE SINTI(N,WSAVE)
+C***BEGIN PROLOGUE SINTI
+C***DATE WRITTEN 790601 (YYMMDD)
+C***REVISION DATE 830401 (YYMMDD)
+C***CATEGORY NO. J1A3
+C***KEYWORDS FOURIER TRANSFORM
+C***AUTHOR SWARZTRAUBER, P. N., (NCAR)
+C***PURPOSE Initialize for SINT.
+C***DESCRIPTION
+C
+C Subroutine SINTI initializes the array WSAVE which is used in
+C subroutine SINT. The prime factorization of N together with
+C a tabulation of the trigonometric functions are computed and
+C stored in WSAVE.
+C
+C Input Parameter
+C
+C N the length of the sequence to be transformed. The method
+C is most efficient when N+1 is a product of small primes.
+C
+C Output Parameter
+C
+C WSAVE a work array with at least INT(3.5*N+16) locations.
+C Different WSAVE arrays are required for different values
+C of N. The contents of WSAVE must not be changed between
+C calls of SINT.
+C***REFERENCES (NONE)
+C***ROUTINES CALLED RFFTI
+C***END PROLOGUE SINTI
+ DIMENSION WSAVE(1)
+ DATA PI /3.14159265358979/
+C***FIRST EXECUTABLE STATEMENT SINTI
+ IF (N .LE. 1) RETURN
+ NP1 = N+1
+ NS2 = N/2
+ DT = PI/FLOAT(NP1)
+ KS = N+2
+ KF = KS+NS2-1
+ FK = 0.
+ DO 101 K=KS,KF
+ FK = FK+1.
+ WSAVE(K) = 2.*SIN(FK*DT)
+ 101 CONTINUE
+ CALL RFFTI (NP1,WSAVE(KF+1))
+ RETURN
+ END
+ SUBROUTINE TRID(MR,A,B,C,Y,D)
+C***BEGIN PROLOGUE TRID
+C***REFER TO POIS3D
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE TRID
+ DIMENSION A(1) ,B(1) ,C(1) ,Y(1) ,
+ 1 D(1)
+C***FIRST EXECUTABLE STATEMENT TRID
+ M = MR
+ MM1 = M-1
+ Z = 1./B(1)
+ D(1) = C(1)*Z
+ Y(1) = Y(1)*Z
+ DO 101 I=2,MM1
+ Z = 1./(B(I)-A(I)*D(I-1))
+ D(I) = C(I)*Z
+ Y(I) = (Y(I)-A(I)*Y(I-1))*Z
+ 101 CONTINUE
+ Z = B(M)-A(M)*D(MM1)
+ IF (Z .NE. 0.) GO TO 102
+ Y(M) = 0.
+ GO TO 103
+ 102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
+ 103 CONTINUE
+ DO 104 IP=1,MM1
+ I = M-IP
+ Y(I) = Y(I)-D(I)*Y(I+1)
+ 104 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+C***BEGIN PROLOGUE PASSB5
+C***REFER TO CFFTB
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSB5
+ DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+C***FIRST EXECUTABLE STATEMENT PASSB5
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TI5 = CC(2,2,K)-CC(2,5,K)
+ TI2 = CC(2,2,K)+CC(2,5,K)
+ TI4 = CC(2,3,K)-CC(2,4,K)
+ TI3 = CC(2,3,K)+CC(2,4,K)
+ TR5 = CC(1,2,K)-CC(1,5,K)
+ TR2 = CC(1,2,K)+CC(1,5,K)
+ TR4 = CC(1,3,K)-CC(1,4,K)
+ TR3 = CC(1,3,K)+CC(1,4,K)
+ CH(1,K,1) = CC(1,1,K)+TR2+TR3
+ CH(2,K,1) = CC(2,1,K)+TI2+TI3
+ CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ CH(1,K,2) = CR2-CI5
+ CH(1,K,5) = CR2+CI5
+ CH(2,K,2) = CI2+CR5
+ CH(2,K,3) = CI3+CR4
+ CH(1,K,3) = CR3-CI4
+ CH(1,K,4) = CR3+CI4
+ CH(2,K,4) = CI3-CR4
+ CH(2,K,5) = CI2-CR5
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TI5 = CC(I,2,K)-CC(I,5,K)
+ TI2 = CC(I,2,K)+CC(I,5,K)
+ TI4 = CC(I,3,K)-CC(I,4,K)
+ TI3 = CC(I,3,K)+CC(I,4,K)
+ TR5 = CC(I-1,2,K)-CC(I-1,5,K)
+ TR2 = CC(I-1,2,K)+CC(I-1,5,K)
+ TR4 = CC(I-1,3,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,3,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
+ CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
+ CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
+ CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
+ CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
+ CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
+ CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
+ CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TI5 = CC(I,2,K)-CC(I,5,K)
+ TI2 = CC(I,2,K)+CC(I,5,K)
+ TI4 = CC(I,3,K)-CC(I,4,K)
+ TI3 = CC(I,3,K)+CC(I,4,K)
+ TR5 = CC(I-1,2,K)-CC(I-1,5,K)
+ TR2 = CC(I-1,2,K)+CC(I-1,5,K)
+ TR4 = CC(I-1,3,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,3,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
+ CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
+ CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
+ CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
+ CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
+ CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
+ CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
+ CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
+ SUBROUTINE PASSF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+C***BEGIN PROLOGUE PASSF5
+C***REFER TO CFFTF
+C***ROUTINES CALLED (NONE)
+C***END PROLOGUE PASSF5
+ DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,
+ 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154,
+ 1-.809016994374947,-.587785252292473/
+C***FIRST EXECUTABLE STATEMENT PASSF5
+ IF (IDO .NE. 2) GO TO 102
+ DO 101 K=1,L1
+ TI5 = CC(2,2,K)-CC(2,5,K)
+ TI2 = CC(2,2,K)+CC(2,5,K)
+ TI4 = CC(2,3,K)-CC(2,4,K)
+ TI3 = CC(2,3,K)+CC(2,4,K)
+ TR5 = CC(1,2,K)-CC(1,5,K)
+ TR2 = CC(1,2,K)+CC(1,5,K)
+ TR4 = CC(1,3,K)-CC(1,4,K)
+ TR3 = CC(1,3,K)+CC(1,4,K)
+ CH(1,K,1) = CC(1,1,K)+TR2+TR3
+ CH(2,K,1) = CC(2,1,K)+TI2+TI3
+ CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ CH(1,K,2) = CR2-CI5
+ CH(1,K,5) = CR2+CI5
+ CH(2,K,2) = CI2+CR5
+ CH(2,K,3) = CI3+CR4
+ CH(1,K,3) = CR3-CI4
+ CH(1,K,4) = CR3+CI4
+ CH(2,K,4) = CI3-CR4
+ CH(2,K,5) = CI2-CR5
+ 101 CONTINUE
+ RETURN
+ 102 IF(IDO/2.LT.L1) GO TO 105
+ DO 104 K=1,L1
+CDIR$ IVDEP
+ DO 103 I=2,IDO,2
+ TI5 = CC(I,2,K)-CC(I,5,K)
+ TI2 = CC(I,2,K)+CC(I,5,K)
+ TI4 = CC(I,3,K)-CC(I,4,K)
+ TI3 = CC(I,3,K)+CC(I,4,K)
+ TR5 = CC(I-1,2,K)-CC(I-1,5,K)
+ TR2 = CC(I-1,2,K)+CC(I-1,5,K)
+ TR4 = CC(I-1,3,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,3,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
+ CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
+ CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
+ CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
+ CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
+ CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
+ CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
+ CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
+ 103 CONTINUE
+ 104 CONTINUE
+ RETURN
+ 105 DO 107 I=2,IDO,2
+CDIR$ IVDEP
+ DO 106 K=1,L1
+ TI5 = CC(I,2,K)-CC(I,5,K)
+ TI2 = CC(I,2,K)+CC(I,5,K)
+ TI4 = CC(I,3,K)-CC(I,4,K)
+ TI3 = CC(I,3,K)+CC(I,4,K)
+ TR5 = CC(I-1,2,K)-CC(I-1,5,K)
+ TR2 = CC(I-1,2,K)+CC(I-1,5,K)
+ TR4 = CC(I-1,3,K)-CC(I-1,4,K)
+ TR3 = CC(I-1,3,K)+CC(I-1,4,K)
+ CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
+ CH(I,K,1) = CC(I,1,K)+TI2+TI3
+ CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
+ CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
+ CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
+ CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
+ CR5 = TI11*TR5+TI12*TR4
+ CI5 = TI11*TI5+TI12*TI4
+ CR4 = TI12*TR5-TI11*TR4
+ CI4 = TI12*TI5-TI11*TI4
+ DR3 = CR3-CI4
+ DR4 = CR3+CI4
+ DI3 = CI3+CR4
+ DI4 = CI3-CR4
+ DR5 = CR2+CI5
+ DR2 = CR2-CI5
+ DI5 = CI2-CR5
+ DI2 = CI2+CR5
+ CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
+ CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
+ CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
+ CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
+ CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
+ CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
+ CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
+ CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
+ 106 CONTINUE
+ 107 CONTINUE
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/read.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/read.f
new file mode 100644
index 0000000000000000000000000000000000000000..e9b93d5b9ae39de97f3e2f0ceefbf112ed8587f2
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/read.f
@@ -0,0 +1,71 @@
+ program lecture
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ character*30 rota
+
+ pi=3.1415926
+ piinv = 1./( pi)
+ pi2=2.*pi
+
+ nx=32
+ ny=32
+ nz=32
+
+
+c rota='rotax'//'0'
+ open(17,file='rotax0',form='unformatted',
+ 1 status='unknown')
+ read(17) (((omg1(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ close(17)
+c
+c rota='rotay'//'0'
+ open(18,file='rotay0',form='unformatted',
+ 1 status='unknown')
+ read(18) (((omg2(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ close(18)
+c
+c rota='rotaz'//'0'
+ open(19,file='rotaz0',form='unformatted',
+ 1 status='unknown')
+ read(19) (((omg3(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ close(19)
+
+
+ open(17,file='rotax0_asci')
+ open(18,file='rotay0_asci')
+ open(19,file='rotaz0_asci')
+
+ do i=1,nx
+ do j=1,nx
+ do k=1,nx
+ write(17,*) omg1(i,j,k)
+ write(18,*) omg2(i,j,k)
+ write(19,*) omg3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ close(17)
+ close(18)
+ close(19)
+ enstro=0.
+
+ do i=1,nx
+ do j=1,nx
+ do k=1,nx
+ enstro=enstro+omg1(i,j,k)
+c print*, omg1(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ print*,enstro/(nx**3)
+
+ stop
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_lambda3.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_lambda3.f
new file mode 100644
index 0000000000000000000000000000000000000000..ae4d64e8eedf4434a0ac43763dcb5a91ac489474
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_lambda3.f
@@ -0,0 +1,630 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE remeshdif(npart,circlim,om1,om2,om3,
+ 1 xp,yp,zp,dv,idif,anu,delt,coef_les,ipoint)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension om1(*),om2(*),om3(*),xp(*),yp(*),zp(*),dv(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ pi=3.1415926
+
+ do 10 k=1,nz
+ do 10 j=1,ny
+ do 10 i=1,nx
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+10 continue
+
+ dxinv=1./dx
+ dyinv=1./dy
+ dzinv=1./dz
+
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+c x0=xmin-.5*dx
+c y0=ymin-.5*dy
+c z0=zmin-.5*dz
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ xm=xmax-xmin
+ ym=ymax-ymin
+ zm=zmax-zmin
+
+ DO 20 n = 1,npart
+
+ g1 = om1(n)
+ g2 = om2(n)
+ g3 = om3(n)
+ x = xp(n)
+ y = yp(n)
+ z = zp(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+C Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dy-y0)*dyinv
+ zz1 = (z - float(kp1)*dz-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et npx-1, puis on numerote de 1 a npx
+C
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+
+ jp1=mod(jp1+ny,ny) +1
+ jp0=mod(jp0+ny,ny) +1
+ jp2=mod(jp2+ny,ny) +1
+ jp3=mod(jp3+ny,ny) +1
+
+ kp1=mod(kp1+nz,nz) +1
+ kp0=mod(kp0+nz,nz) +1
+ kp2=mod(kp2+nz,nz) +1
+ kp3=mod(kp3+nz,nz) +1
+
+C The M'4 scheme
+C
+
+ a1 = .5*(1.-xx1**2)*(2.-xx1)
+ b1 = .5*(1.-yy1**2)*(2.-yy1)
+ c1 = .5*(1.-zz1**2)*(2.-zz1)
+
+ a0 = (1.-xx0)*(2.-xx0)*(3.-xx0)/6.
+ b0 = (1.-yy0)*(2.-yy0)*(3.-yy0)/6.
+ c0 = (1.-zz0)*(2.-zz0)*(3.-zz0)/6.
+
+ a3 = (1.-xx3)*(2.-xx3)*(3.-xx3)/6.
+ b3 = (1.-yy3)*(2.-yy3)*(3.-yy3)/6.
+ c3 = (1.-zz3)*(2.-zz3)*(3.-zz3)/6.
+
+ a2 = .5*(1.-xx2**2)*(2.-xx2)
+ b2 = .5*(1.-yy2**2)*(2.-yy2)
+ c2 = .5*(1.-zz2**2)*(2.-zz2)
+
+ coef=a0*b0*c0
+ omg1(ip0,jp0,kp0) = omg1(ip0,jp0,kp0) + g1*coef
+ omg2(ip0,jp0,kp0) = omg2(ip0,jp0,kp0) + g2*coef
+ omg3(ip0,jp0,kp0) = omg3(ip0,jp0,kp0) + g3*coef
+
+ coef=a0*b0*c1
+ omg1(ip0,jp0,kp1) = omg1(ip0,jp0,kp1) + g1*coef
+ omg2(ip0,jp0,kp1) = omg2(ip0,jp0,kp1) + g2*coef
+ omg3(ip0,jp0,kp1) = omg3(ip0,jp0,kp1) + g3*coef
+
+ coef=a0*b0*c2
+ omg1(ip0,jp0,kp2) = omg1(ip0,jp0,kp2) + g1*coef
+ omg2(ip0,jp0,kp2) = omg2(ip0,jp0,kp2) + g2*coef
+ omg3(ip0,jp0,kp2) = omg3(ip0,jp0,kp2) + g3*coef
+
+ coef=a0*b0*c3
+ omg1(ip0,jp0,kp3) = omg1(ip0,jp0,kp3) + g1*coef
+ omg2(ip0,jp0,kp3) = omg2(ip0,jp0,kp3) + g2*coef
+ omg3(ip0,jp0,kp3) = omg3(ip0,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b1*c0
+ omg1(ip0,jp1,kp0) = omg1(ip0,jp1,kp0) + g1*coef
+ omg2(ip0,jp1,kp0) = omg2(ip0,jp1,kp0) + g2*coef
+ omg3(ip0,jp1,kp0) = omg3(ip0,jp1,kp0) + g3*coef
+
+ coef=a0*b1*c1
+ omg1(ip0,jp1,kp1) = omg1(ip0,jp1,kp1) + g1*coef
+ omg2(ip0,jp1,kp1) = omg2(ip0,jp1,kp1) + g2*coef
+ omg3(ip0,jp1,kp1) = omg3(ip0,jp1,kp1) + g3*coef
+
+ coef=a0*b1*c2
+ omg1(ip0,jp1,kp2) = omg1(ip0,jp1,kp2) + g1*coef
+ omg2(ip0,jp1,kp2) = omg2(ip0,jp1,kp2) + g2*coef
+ omg3(ip0,jp1,kp2) = omg3(ip0,jp1,kp2) + g3*coef
+
+ coef=a0*b1*c3
+ omg1(ip0,jp1,kp3) = omg1(ip0,jp1,kp3) + g1*coef
+ omg2(ip0,jp1,kp3) = omg2(ip0,jp1,kp3) + g2*coef
+ omg3(ip0,jp1,kp3) = omg3(ip0,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b2*c0
+ omg1(ip0,jp2,kp0) = omg1(ip0,jp2,kp0) + g1*coef
+ omg2(ip0,jp2,kp0) = omg2(ip0,jp2,kp0) + g2*coef
+ omg3(ip0,jp2,kp0) = omg3(ip0,jp2,kp0) + g3*coef
+
+ coef=a0*b2*c1
+ omg1(ip0,jp2,kp1) = omg1(ip0,jp2,kp1) + g1*coef
+ omg2(ip0,jp2,kp1) = omg2(ip0,jp2,kp1) + g2*coef
+ omg3(ip0,jp2,kp1) = omg3(ip0,jp2,kp1) + g3*coef
+
+ coef=a0*b2*c2
+ omg1(ip0,jp2,kp2) = omg1(ip0,jp2,kp2) + g1*coef
+ omg2(ip0,jp2,kp2) = omg2(ip0,jp2,kp2) + g2*coef
+ omg3(ip0,jp2,kp2) = omg3(ip0,jp2,kp2) + g3*coef
+
+ coef=a0*b2*c3
+ omg1(ip0,jp2,kp3) = omg1(ip0,jp2,kp3) + g1*coef
+ omg2(ip0,jp2,kp3) = omg2(ip0,jp2,kp3) + g2*coef
+ omg3(ip0,jp2,kp3) = omg3(ip0,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b3*c0
+ omg1(ip0,jp3,kp0) = omg1(ip0,jp3,kp0) + g1*coef
+ omg2(ip0,jp3,kp0) = omg2(ip0,jp3,kp0) + g2*coef
+ omg3(ip0,jp3,kp0) = omg3(ip0,jp3,kp0) + g3*coef
+
+ coef=a0*b3*c1
+ omg1(ip0,jp3,kp1) = omg1(ip0,jp3,kp1) + g1*coef
+ omg2(ip0,jp3,kp1) = omg2(ip0,jp3,kp1) + g2*coef
+ omg3(ip0,jp3,kp1) = omg3(ip0,jp3,kp1) + g3*coef
+
+ coef=a0*b3*c2
+ omg1(ip0,jp3,kp2) = omg1(ip0,jp3,kp2) + g1*coef
+ omg2(ip0,jp3,kp2) = omg2(ip0,jp3,kp2) + g2*coef
+ omg3(ip0,jp3,kp2) = omg3(ip0,jp3,kp2) + g3*coef
+
+ coef=a0*b3*c3
+ omg1(ip0,jp3,kp3) = omg1(ip0,jp3,kp3) + g1*coef
+ omg2(ip0,jp3,kp3) = omg2(ip0,jp3,kp3) + g2*coef
+ omg3(ip0,jp3,kp3) = omg3(ip0,jp3,kp3) + g3*coef
+
+ccc
+ coef=a1*b0*c0
+ omg1(ip1,jp0,kp0) = omg1(ip1,jp0,kp0) + g1*coef
+ omg2(ip1,jp0,kp0) = omg2(ip1,jp0,kp0) + g2*coef
+ omg3(ip1,jp0,kp0) = omg3(ip1,jp0,kp0) + g3*coef
+
+ coef=a1*b0*c1
+ omg1(ip1,jp0,kp1) = omg1(ip1,jp0,kp1) + g1*coef
+ omg2(ip1,jp0,kp1) = omg2(ip1,jp0,kp1) + g2*coef
+ omg3(ip1,jp0,kp1) = omg3(ip1,jp0,kp1) + g3*coef
+
+ coef=a1*b0*c2
+ omg1(ip1,jp0,kp2) = omg1(ip1,jp0,kp2) + g1*coef
+ omg2(ip1,jp0,kp2) = omg2(ip1,jp0,kp2) + g2*coef
+ omg3(ip1,jp0,kp2) = omg3(ip1,jp0,kp2) + g3*coef
+
+ coef=a1*b0*c3
+ omg1(ip1,jp0,kp3) = omg1(ip1,jp0,kp3) + g1*coef
+ omg2(ip1,jp0,kp3) = omg2(ip1,jp0,kp3) + g2*coef
+ omg3(ip1,jp0,kp3) = omg3(ip1,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b1*c0
+ omg1(ip1,jp1,kp0) = omg1(ip1,jp1,kp0) + g1*coef
+ omg2(ip1,jp1,kp0) = omg2(ip1,jp1,kp0) + g2*coef
+ omg3(ip1,jp1,kp0) = omg3(ip1,jp1,kp0) + g3*coef
+
+ coef=a1*b1*c1
+ omg1(ip1,jp1,kp1) = omg1(ip1,jp1,kp1) + g1*coef
+ omg2(ip1,jp1,kp1) = omg2(ip1,jp1,kp1) + g2*coef
+ omg3(ip1,jp1,kp1) = omg3(ip1,jp1,kp1) + g3*coef
+
+ coef=a1*b1*c2
+ omg1(ip1,jp1,kp2) = omg1(ip1,jp1,kp2) + g1*coef
+ omg2(ip1,jp1,kp2) = omg2(ip1,jp1,kp2) + g2*coef
+ omg3(ip1,jp1,kp2) = omg3(ip1,jp1,kp2) + g3*coef
+
+ coef=a1*b1*c3
+ omg1(ip1,jp1,kp3) = omg1(ip1,jp1,kp3) + g1*coef
+ omg2(ip1,jp1,kp3) = omg2(ip1,jp1,kp3) + g2*coef
+ omg3(ip1,jp1,kp3) = omg3(ip1,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b2*c0
+ omg1(ip1,jp2,kp0) = omg1(ip1,jp2,kp0) + g1*coef
+ omg2(ip1,jp2,kp0) = omg2(ip1,jp2,kp0) + g2*coef
+ omg3(ip1,jp2,kp0) = omg3(ip1,jp2,kp0) + g3*coef
+
+ coef=a1*b2*c1
+ omg1(ip1,jp2,kp1) = omg1(ip1,jp2,kp1) + g1*coef
+ omg2(ip1,jp2,kp1) = omg2(ip1,jp2,kp1) + g2*coef
+ omg3(ip1,jp2,kp1) = omg3(ip1,jp2,kp1) + g3*coef
+
+ coef=a1*b2*c2
+ omg1(ip1,jp2,kp2) = omg1(ip1,jp2,kp2) + g1*coef
+ omg2(ip1,jp2,kp2) = omg2(ip1,jp2,kp2) + g2*coef
+ omg3(ip1,jp2,kp2) = omg3(ip1,jp2,kp2) + g3*coef
+
+ coef=a1*b2*c3
+ omg1(ip1,jp2,kp3) = omg1(ip1,jp2,kp3) + g1*coef
+ omg2(ip1,jp2,kp3) = omg2(ip1,jp2,kp3) + g2*coef
+ omg3(ip1,jp2,kp3) = omg3(ip1,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b3*c0
+ omg1(ip1,jp3,kp0) = omg1(ip1,jp3,kp0) + g1*coef
+ omg2(ip1,jp3,kp0) = omg2(ip1,jp3,kp0) + g2*coef
+ omg3(ip1,jp3,kp0) = omg3(ip1,jp3,kp0) + g3*coef
+
+ coef=a1*b3*c1
+ omg1(ip1,jp3,kp1) = omg1(ip1,jp3,kp1) + g1*coef
+ omg2(ip1,jp3,kp1) = omg2(ip1,jp3,kp1) + g2*coef
+ omg3(ip1,jp3,kp1) = omg3(ip1,jp3,kp1) + g3*coef
+
+ coef=a1*b3*c2
+ omg1(ip1,jp3,kp2) = omg1(ip1,jp3,kp2) + g1*coef
+ omg2(ip1,jp3,kp2) = omg2(ip1,jp3,kp2) + g2*coef
+ omg3(ip1,jp3,kp2) = omg3(ip1,jp3,kp2) + g3*coef
+
+ coef=a1*b3*c3
+ omg1(ip1,jp3,kp3) = omg1(ip1,jp3,kp3) + g1*coef
+ omg2(ip1,jp3,kp3) = omg2(ip1,jp3,kp3) + g2*coef
+ omg3(ip1,jp3,kp3) = omg3(ip1,jp3,kp3) + g3*coef
+
+ccc
+ coef=a2*b0*c0
+ omg1(ip2,jp0,kp0) = omg1(ip2,jp0,kp0) + g1*coef
+ omg2(ip2,jp0,kp0) = omg2(ip2,jp0,kp0) + g2*coef
+ omg3(ip2,jp0,kp0) = omg3(ip2,jp0,kp0) + g3*coef
+
+ coef=a2*b0*c1
+ omg1(ip2,jp0,kp1) = omg1(ip2,jp0,kp1) + g1*coef
+ omg2(ip2,jp0,kp1) = omg2(ip2,jp0,kp1) + g2*coef
+ omg3(ip2,jp0,kp1) = omg3(ip2,jp0,kp1) + g3*coef
+
+ coef=a2*b0*c2
+ omg1(ip2,jp0,kp2) = omg1(ip2,jp0,kp2) + g1*coef
+ omg2(ip2,jp0,kp2) = omg2(ip2,jp0,kp2) + g2*coef
+ omg3(ip2,jp0,kp2) = omg3(ip2,jp0,kp2) + g3*coef
+
+ coef=a2*b0*c3
+ omg1(ip2,jp0,kp3) = omg1(ip2,jp0,kp3) + g1*coef
+ omg2(ip2,jp0,kp3) = omg2(ip2,jp0,kp3) + g2*coef
+ omg3(ip2,jp0,kp3) = omg3(ip2,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b1*c0
+ omg1(ip2,jp1,kp0) = omg1(ip2,jp1,kp0) + g1*coef
+ omg2(ip2,jp1,kp0) = omg2(ip2,jp1,kp0) + g2*coef
+ omg3(ip2,jp1,kp0) = omg3(ip2,jp1,kp0) + g3*coef
+
+ coef=a2*b1*c1
+ omg1(ip2,jp1,kp1) = omg1(ip2,jp1,kp1) + g1*coef
+ omg2(ip2,jp1,kp1) = omg2(ip2,jp1,kp1) + g2*coef
+ omg3(ip2,jp1,kp1) = omg3(ip2,jp1,kp1) + g3*coef
+
+ coef=a2*b1*c2
+ omg1(ip2,jp1,kp2) = omg1(ip2,jp1,kp2) + g1*coef
+ omg2(ip2,jp1,kp2) = omg2(ip2,jp1,kp2) + g2*coef
+ omg3(ip2,jp1,kp2) = omg3(ip2,jp1,kp2) + g3*coef
+
+ coef=a2*b1*c3
+ omg1(ip2,jp1,kp3) = omg1(ip2,jp1,kp3) + g1*coef
+ omg2(ip2,jp1,kp3) = omg2(ip2,jp1,kp3) + g2*coef
+ omg3(ip2,jp1,kp3) = omg3(ip2,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b2*c0
+ omg1(ip2,jp2,kp0) = omg1(ip2,jp2,kp0) + g1*coef
+ omg2(ip2,jp2,kp0) = omg2(ip2,jp2,kp0) + g2*coef
+ omg3(ip2,jp2,kp0) = omg3(ip2,jp2,kp0) + g3*coef
+
+ coef=a2*b2*c1
+ omg1(ip2,jp2,kp1) = omg1(ip2,jp2,kp1) + g1*coef
+ omg2(ip2,jp2,kp1) = omg2(ip2,jp2,kp1) + g2*coef
+ omg3(ip2,jp2,kp1) = omg3(ip2,jp2,kp1) + g3*coef
+
+ coef=a2*b2*c2
+ omg1(ip2,jp2,kp2) = omg1(ip2,jp2,kp2) + g1*coef
+ omg2(ip2,jp2,kp2) = omg2(ip2,jp2,kp2) + g2*coef
+ omg3(ip2,jp2,kp2) = omg3(ip2,jp2,kp2) + g3*coef
+
+ coef=a2*b2*c3
+ omg1(ip2,jp2,kp3) = omg1(ip2,jp2,kp3) + g1*coef
+ omg2(ip2,jp2,kp3) = omg2(ip2,jp2,kp3) + g2*coef
+ omg3(ip2,jp2,kp3) = omg3(ip2,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b3*c0
+ omg1(ip2,jp3,kp0) = omg1(ip2,jp3,kp0) + g1*coef
+ omg2(ip2,jp3,kp0) = omg2(ip2,jp3,kp0) + g2*coef
+ omg3(ip2,jp3,kp0) = omg3(ip2,jp3,kp0) + g3*coef
+
+ coef=a2*b3*c1
+ omg1(ip2,jp3,kp1) = omg1(ip2,jp3,kp1) + g1*coef
+ omg2(ip2,jp3,kp1) = omg2(ip2,jp3,kp1) + g2*coef
+ omg3(ip2,jp3,kp1) = omg3(ip2,jp3,kp1) + g3*coef
+
+ coef=a2*b3*c2
+ omg1(ip2,jp3,kp2) = omg1(ip2,jp3,kp2) + g1*coef
+ omg2(ip2,jp3,kp2) = omg2(ip2,jp3,kp2) + g2*coef
+ omg3(ip2,jp3,kp2) = omg3(ip2,jp3,kp2) + g3*coef
+
+ coef=a2*b3*c3
+ omg1(ip2,jp3,kp3) = omg1(ip2,jp3,kp3) + g1*coef
+ omg2(ip2,jp3,kp3) = omg2(ip2,jp3,kp3) + g2*coef
+ omg3(ip2,jp3,kp3) = omg3(ip2,jp3,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b0*c0
+ omg1(ip3,jp0,kp0) = omg1(ip3,jp0,kp0) + g1*coef
+ omg2(ip3,jp0,kp0) = omg2(ip3,jp0,kp0) + g2*coef
+ omg3(ip3,jp0,kp0) = omg3(ip3,jp0,kp0) + g3*coef
+
+ coef=a3*b0*c1
+ omg1(ip3,jp0,kp1) = omg1(ip3,jp0,kp1) + g1*coef
+ omg2(ip3,jp0,kp1) = omg2(ip3,jp0,kp1) + g2*coef
+ omg3(ip3,jp0,kp1) = omg3(ip3,jp0,kp1) + g3*coef
+
+ coef=a3*b0*c2
+ omg1(ip3,jp0,kp2) = omg1(ip3,jp0,kp2) + g1*coef
+ omg2(ip3,jp0,kp2) = omg2(ip3,jp0,kp2) + g2*coef
+ omg3(ip3,jp0,kp2) = omg3(ip3,jp0,kp2) + g3*coef
+
+ coef=a3*b0*c3
+ omg1(ip3,jp0,kp3) = omg1(ip3,jp0,kp3) + g1*coef
+ omg2(ip3,jp0,kp3) = omg2(ip3,jp0,kp3) + g2*coef
+ omg3(ip3,jp0,kp3) = omg3(ip3,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b1*c0
+ omg1(ip3,jp1,kp0) = omg1(ip3,jp1,kp0) + g1*coef
+ omg2(ip3,jp1,kp0) = omg2(ip3,jp1,kp0) + g2*coef
+ omg3(ip3,jp1,kp0) = omg3(ip3,jp1,kp0) + g3*coef
+
+ coef=a3*b1*c1
+ omg1(ip3,jp1,kp1) = omg1(ip3,jp1,kp1) + g1*coef
+ omg2(ip3,jp1,kp1) = omg2(ip3,jp1,kp1) + g2*coef
+ omg3(ip3,jp1,kp1) = omg3(ip3,jp1,kp1) + g3*coef
+
+ coef=a3*b1*c2
+ omg1(ip3,jp1,kp2) = omg1(ip3,jp1,kp2) + g1*coef
+ omg2(ip3,jp1,kp2) = omg2(ip3,jp1,kp2) + g2*coef
+ omg3(ip3,jp1,kp2) = omg3(ip3,jp1,kp2) + g3*coef
+
+ coef=a3*b1*c3
+ omg1(ip3,jp1,kp3) = omg1(ip3,jp1,kp3) + g1*coef
+ omg2(ip3,jp1,kp3) = omg2(ip3,jp1,kp3) + g2*coef
+ omg3(ip3,jp1,kp3) = omg3(ip3,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b2*c0
+ omg1(ip3,jp2,kp0) = omg1(ip3,jp2,kp0) + g1*coef
+ omg2(ip3,jp2,kp0) = omg2(ip3,jp2,kp0) + g2*coef
+ omg3(ip3,jp2,kp0) = omg3(ip3,jp2,kp0) + g3*coef
+
+ coef=a3*b2*c1
+ omg1(ip3,jp2,kp1) = omg1(ip3,jp2,kp1) + g1*coef
+ omg2(ip3,jp2,kp1) = omg2(ip3,jp2,kp1) + g2*coef
+ omg3(ip3,jp2,kp1) = omg3(ip3,jp2,kp1) + g3*coef
+
+ coef=a3*b2*c2
+ omg1(ip3,jp2,kp2) = omg1(ip3,jp2,kp2) + g1*coef
+ omg2(ip3,jp2,kp2) = omg2(ip3,jp2,kp2) + g2*coef
+ omg3(ip3,jp2,kp2) = omg3(ip3,jp2,kp2) + g3*coef
+
+ coef=a3*b2*c3
+ omg1(ip3,jp2,kp3) = omg1(ip3,jp2,kp3) + g1*coef
+ omg2(ip3,jp2,kp3) = omg2(ip3,jp2,kp3) + g2*coef
+ omg3(ip3,jp2,kp3) = omg3(ip3,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b3*c0
+ omg1(ip3,jp3,kp0) = omg1(ip3,jp3,kp0) + g1*coef
+ omg2(ip3,jp3,kp0) = omg2(ip3,jp3,kp0) + g2*coef
+ omg3(ip3,jp3,kp0) = omg3(ip3,jp3,kp0) + g3*coef
+
+ coef=a3*b3*c1
+ omg1(ip3,jp3,kp1) = omg1(ip3,jp3,kp1) + g1*coef
+ omg2(ip3,jp3,kp1) = omg2(ip3,jp3,kp1) + g2*coef
+ omg3(ip3,jp3,kp1) = omg3(ip3,jp3,kp1) + g3*coef
+
+ coef=a3*b3*c2
+ omg1(ip3,jp3,kp2) = omg1(ip3,jp3,kp2) + g1*coef
+ omg2(ip3,jp3,kp2) = omg2(ip3,jp3,kp2) + g2*coef
+ omg3(ip3,jp3,kp2) = omg3(ip3,jp3,kp2) + g3*coef
+
+ coef=a3*b3*c3
+ omg1(ip3,jp3,kp3) = omg1(ip3,jp3,kp3) + g1*coef
+ omg2(ip3,jp3,kp3) = omg2(ip3,jp3,kp3) + g2*coef
+ omg3(ip3,jp3,kp3) = omg3(ip3,jp3,kp3) + g3*coef
+
+ccc
+
+20 CONTINUE
+
+ npart=0
+
+ do k=1,nz
+ z=amod(z0-zmin+(k-1)*dz+zm,zm)+zmin
+ do j=1,ny
+ y=amod(y0-ymin+(j-1)*dy+ym,ym)+ymin
+ do i=1,nx
+ x=amod(x0-xmin+(i-1)*dx+xm,xm)+xmin
+ vol=dx*dy*dz
+ strength=abs(omg1(i,j,k))+abs(omg2(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.ge.circlim*vol)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ dv(npart)=vol
+ om1(npart)=omg1(i,j,k)
+ om2(npart)=omg2(i,j,k)
+ om3(npart)=omg3(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+ if (ipoint.eq.0) go to 310
+
+
+c goto 310
+
+ if (idif.ne.0) then
+
+c dans la foulee on fiat la diffusion dans l'espace
+c mappee avec formules de diffusion anisotropes
+
+c pas de temps de diffusion pour CFL
+
+c coeff aspect ratio pour se mettre dans une grille
+c totalement isotrope et coeff de normalisation
+c pour kernel 1/(1+r**2)
+ dzdx=(dz/dx)**2
+ dzdy=(dz/dy)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+c boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+c boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx-1,nx)+1
+ j2=mod(jj+ly+ny-1,ny)+1
+ k2=mod(kk+lz+nz-1,nz)+1
+ gammasrc1=omg1(i2,j2,k2)
+ gammasrc2=omg2(i2,j2,k2)
+ gammasrc3=omg3(i2,j2,k2)
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ dvx=(vxsrc-vxrcv)/dx
+ dvy=(vysrc-vyrcv)/dy
+ dvz=(vzsrc-vzrcv)/dz
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ ales=amax1(0.,dvx*lx+dvy*ly+dvz*lz)/(1.+r)**2
+c ales=abs(dvx*lx+dvy*ly+dvz*lz)/(1.+r)**2
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ factor=akernel/(dz*dz)
+ tot2=tot2+akernel
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*
+ 1 (anu*factor+coef_les*ales)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*
+ 1 (anu*factor+coef_les*ales)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*
+ 1 (anu*factor+coef_les*ales)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy*dx*dz/dv(i))
+
+c enddo pour caluc de dom sur les particules
+ enddo
+
+
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv(i))
+ omax0=amax1(omax0,abs(om2(i))/dv(i))
+ omax0=amax1(omax0,abs(om3(i))/dv(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv(i))
+ omax1=amax1(omax1,abs(om2(i))/dv(i))
+ omax1=amax1(omax1,abs(om3(i))/dv(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+ endif
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_m4.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_m4.f
new file mode 100644
index 0000000000000000000000000000000000000000..3dc2383658f7424b4e87eadd79aa7660016d2617
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/remesh_m4.f
@@ -0,0 +1,629 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE remeshdif(npart,circlim,om1,om2,om3,
+ 1 xp,yp,zp,dv,idif,anu,delt,coef_les,ipoint)
+
+
+
+C
+C This subroutine asssigns vorticity on a grid
+C
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension om1(*),om2(*),om3(*),xp(*),yp(*),zp(*),dv(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ pi=3.1415926
+
+ do 10 k=1,nz
+ do 10 j=1,ny
+ do 10 i=1,nx
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+10 continue
+
+ dxinv=1./dx
+ dyinv=1./dy
+ dzinv=1./dz
+
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+c x0=xmin-.5*dx
+c y0=ymin-.5*dy
+c z0=zmin-.5*dz
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ xm=xmax-xmin
+ ym=ymax-ymin
+ zm=zmax-zmin
+
+ DO 20 n = 1,npart
+
+ g1 = om1(n)
+ g2 = om2(n)
+ g3 = om3(n)
+ x = xp(n)
+ y = yp(n)
+ z = zp(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+C Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dy-y0)*dyinv
+ zz1 = (z - float(kp1)*dz-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et npx-1, puis on numerote de 1 a npx
+C
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+
+ jp1=mod(jp1+ny,ny) +1
+ jp0=mod(jp0+ny,ny) +1
+ jp2=mod(jp2+ny,ny) +1
+ jp3=mod(jp3+ny,ny) +1
+
+ kp1=mod(kp1+nz,nz) +1
+ kp0=mod(kp0+nz,nz) +1
+ kp2=mod(kp2+nz,nz) +1
+ kp3=mod(kp3+nz,nz) +1
+
+C The M'4 scheme
+C
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ coef=a0*b0*c0
+ omg1(ip0,jp0,kp0) = omg1(ip0,jp0,kp0) + g1*coef
+ omg2(ip0,jp0,kp0) = omg2(ip0,jp0,kp0) + g2*coef
+ omg3(ip0,jp0,kp0) = omg3(ip0,jp0,kp0) + g3*coef
+
+ coef=a0*b0*c1
+ omg1(ip0,jp0,kp1) = omg1(ip0,jp0,kp1) + g1*coef
+ omg2(ip0,jp0,kp1) = omg2(ip0,jp0,kp1) + g2*coef
+ omg3(ip0,jp0,kp1) = omg3(ip0,jp0,kp1) + g3*coef
+
+ coef=a0*b0*c2
+ omg1(ip0,jp0,kp2) = omg1(ip0,jp0,kp2) + g1*coef
+ omg2(ip0,jp0,kp2) = omg2(ip0,jp0,kp2) + g2*coef
+ omg3(ip0,jp0,kp2) = omg3(ip0,jp0,kp2) + g3*coef
+
+ coef=a0*b0*c3
+ omg1(ip0,jp0,kp3) = omg1(ip0,jp0,kp3) + g1*coef
+ omg2(ip0,jp0,kp3) = omg2(ip0,jp0,kp3) + g2*coef
+ omg3(ip0,jp0,kp3) = omg3(ip0,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b1*c0
+ omg1(ip0,jp1,kp0) = omg1(ip0,jp1,kp0) + g1*coef
+ omg2(ip0,jp1,kp0) = omg2(ip0,jp1,kp0) + g2*coef
+ omg3(ip0,jp1,kp0) = omg3(ip0,jp1,kp0) + g3*coef
+
+ coef=a0*b1*c1
+ omg1(ip0,jp1,kp1) = omg1(ip0,jp1,kp1) + g1*coef
+ omg2(ip0,jp1,kp1) = omg2(ip0,jp1,kp1) + g2*coef
+ omg3(ip0,jp1,kp1) = omg3(ip0,jp1,kp1) + g3*coef
+
+ coef=a0*b1*c2
+ omg1(ip0,jp1,kp2) = omg1(ip0,jp1,kp2) + g1*coef
+ omg2(ip0,jp1,kp2) = omg2(ip0,jp1,kp2) + g2*coef
+ omg3(ip0,jp1,kp2) = omg3(ip0,jp1,kp2) + g3*coef
+
+ coef=a0*b1*c3
+ omg1(ip0,jp1,kp3) = omg1(ip0,jp1,kp3) + g1*coef
+ omg2(ip0,jp1,kp3) = omg2(ip0,jp1,kp3) + g2*coef
+ omg3(ip0,jp1,kp3) = omg3(ip0,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b2*c0
+ omg1(ip0,jp2,kp0) = omg1(ip0,jp2,kp0) + g1*coef
+ omg2(ip0,jp2,kp0) = omg2(ip0,jp2,kp0) + g2*coef
+ omg3(ip0,jp2,kp0) = omg3(ip0,jp2,kp0) + g3*coef
+
+ coef=a0*b2*c1
+ omg1(ip0,jp2,kp1) = omg1(ip0,jp2,kp1) + g1*coef
+ omg2(ip0,jp2,kp1) = omg2(ip0,jp2,kp1) + g2*coef
+ omg3(ip0,jp2,kp1) = omg3(ip0,jp2,kp1) + g3*coef
+
+ coef=a0*b2*c2
+ omg1(ip0,jp2,kp2) = omg1(ip0,jp2,kp2) + g1*coef
+ omg2(ip0,jp2,kp2) = omg2(ip0,jp2,kp2) + g2*coef
+ omg3(ip0,jp2,kp2) = omg3(ip0,jp2,kp2) + g3*coef
+
+ coef=a0*b2*c3
+ omg1(ip0,jp2,kp3) = omg1(ip0,jp2,kp3) + g1*coef
+ omg2(ip0,jp2,kp3) = omg2(ip0,jp2,kp3) + g2*coef
+ omg3(ip0,jp2,kp3) = omg3(ip0,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a0*b3*c0
+ omg1(ip0,jp3,kp0) = omg1(ip0,jp3,kp0) + g1*coef
+ omg2(ip0,jp3,kp0) = omg2(ip0,jp3,kp0) + g2*coef
+ omg3(ip0,jp3,kp0) = omg3(ip0,jp3,kp0) + g3*coef
+
+ coef=a0*b3*c1
+ omg1(ip0,jp3,kp1) = omg1(ip0,jp3,kp1) + g1*coef
+ omg2(ip0,jp3,kp1) = omg2(ip0,jp3,kp1) + g2*coef
+ omg3(ip0,jp3,kp1) = omg3(ip0,jp3,kp1) + g3*coef
+
+ coef=a0*b3*c2
+ omg1(ip0,jp3,kp2) = omg1(ip0,jp3,kp2) + g1*coef
+ omg2(ip0,jp3,kp2) = omg2(ip0,jp3,kp2) + g2*coef
+ omg3(ip0,jp3,kp2) = omg3(ip0,jp3,kp2) + g3*coef
+
+ coef=a0*b3*c3
+ omg1(ip0,jp3,kp3) = omg1(ip0,jp3,kp3) + g1*coef
+ omg2(ip0,jp3,kp3) = omg2(ip0,jp3,kp3) + g2*coef
+ omg3(ip0,jp3,kp3) = omg3(ip0,jp3,kp3) + g3*coef
+
+ccc
+ coef=a1*b0*c0
+ omg1(ip1,jp0,kp0) = omg1(ip1,jp0,kp0) + g1*coef
+ omg2(ip1,jp0,kp0) = omg2(ip1,jp0,kp0) + g2*coef
+ omg3(ip1,jp0,kp0) = omg3(ip1,jp0,kp0) + g3*coef
+
+ coef=a1*b0*c1
+ omg1(ip1,jp0,kp1) = omg1(ip1,jp0,kp1) + g1*coef
+ omg2(ip1,jp0,kp1) = omg2(ip1,jp0,kp1) + g2*coef
+ omg3(ip1,jp0,kp1) = omg3(ip1,jp0,kp1) + g3*coef
+
+ coef=a1*b0*c2
+ omg1(ip1,jp0,kp2) = omg1(ip1,jp0,kp2) + g1*coef
+ omg2(ip1,jp0,kp2) = omg2(ip1,jp0,kp2) + g2*coef
+ omg3(ip1,jp0,kp2) = omg3(ip1,jp0,kp2) + g3*coef
+
+ coef=a1*b0*c3
+ omg1(ip1,jp0,kp3) = omg1(ip1,jp0,kp3) + g1*coef
+ omg2(ip1,jp0,kp3) = omg2(ip1,jp0,kp3) + g2*coef
+ omg3(ip1,jp0,kp3) = omg3(ip1,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b1*c0
+ omg1(ip1,jp1,kp0) = omg1(ip1,jp1,kp0) + g1*coef
+ omg2(ip1,jp1,kp0) = omg2(ip1,jp1,kp0) + g2*coef
+ omg3(ip1,jp1,kp0) = omg3(ip1,jp1,kp0) + g3*coef
+
+ coef=a1*b1*c1
+ omg1(ip1,jp1,kp1) = omg1(ip1,jp1,kp1) + g1*coef
+ omg2(ip1,jp1,kp1) = omg2(ip1,jp1,kp1) + g2*coef
+ omg3(ip1,jp1,kp1) = omg3(ip1,jp1,kp1) + g3*coef
+
+ coef=a1*b1*c2
+ omg1(ip1,jp1,kp2) = omg1(ip1,jp1,kp2) + g1*coef
+ omg2(ip1,jp1,kp2) = omg2(ip1,jp1,kp2) + g2*coef
+ omg3(ip1,jp1,kp2) = omg3(ip1,jp1,kp2) + g3*coef
+
+ coef=a1*b1*c3
+ omg1(ip1,jp1,kp3) = omg1(ip1,jp1,kp3) + g1*coef
+ omg2(ip1,jp1,kp3) = omg2(ip1,jp1,kp3) + g2*coef
+ omg3(ip1,jp1,kp3) = omg3(ip1,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b2*c0
+ omg1(ip1,jp2,kp0) = omg1(ip1,jp2,kp0) + g1*coef
+ omg2(ip1,jp2,kp0) = omg2(ip1,jp2,kp0) + g2*coef
+ omg3(ip1,jp2,kp0) = omg3(ip1,jp2,kp0) + g3*coef
+
+ coef=a1*b2*c1
+ omg1(ip1,jp2,kp1) = omg1(ip1,jp2,kp1) + g1*coef
+ omg2(ip1,jp2,kp1) = omg2(ip1,jp2,kp1) + g2*coef
+ omg3(ip1,jp2,kp1) = omg3(ip1,jp2,kp1) + g3*coef
+
+ coef=a1*b2*c2
+ omg1(ip1,jp2,kp2) = omg1(ip1,jp2,kp2) + g1*coef
+ omg2(ip1,jp2,kp2) = omg2(ip1,jp2,kp2) + g2*coef
+ omg3(ip1,jp2,kp2) = omg3(ip1,jp2,kp2) + g3*coef
+
+ coef=a1*b2*c3
+ omg1(ip1,jp2,kp3) = omg1(ip1,jp2,kp3) + g1*coef
+ omg2(ip1,jp2,kp3) = omg2(ip1,jp2,kp3) + g2*coef
+ omg3(ip1,jp2,kp3) = omg3(ip1,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a1*b3*c0
+ omg1(ip1,jp3,kp0) = omg1(ip1,jp3,kp0) + g1*coef
+ omg2(ip1,jp3,kp0) = omg2(ip1,jp3,kp0) + g2*coef
+ omg3(ip1,jp3,kp0) = omg3(ip1,jp3,kp0) + g3*coef
+
+ coef=a1*b3*c1
+ omg1(ip1,jp3,kp1) = omg1(ip1,jp3,kp1) + g1*coef
+ omg2(ip1,jp3,kp1) = omg2(ip1,jp3,kp1) + g2*coef
+ omg3(ip1,jp3,kp1) = omg3(ip1,jp3,kp1) + g3*coef
+
+ coef=a1*b3*c2
+ omg1(ip1,jp3,kp2) = omg1(ip1,jp3,kp2) + g1*coef
+ omg2(ip1,jp3,kp2) = omg2(ip1,jp3,kp2) + g2*coef
+ omg3(ip1,jp3,kp2) = omg3(ip1,jp3,kp2) + g3*coef
+
+ coef=a1*b3*c3
+ omg1(ip1,jp3,kp3) = omg1(ip1,jp3,kp3) + g1*coef
+ omg2(ip1,jp3,kp3) = omg2(ip1,jp3,kp3) + g2*coef
+ omg3(ip1,jp3,kp3) = omg3(ip1,jp3,kp3) + g3*coef
+
+ccc
+ coef=a2*b0*c0
+ omg1(ip2,jp0,kp0) = omg1(ip2,jp0,kp0) + g1*coef
+ omg2(ip2,jp0,kp0) = omg2(ip2,jp0,kp0) + g2*coef
+ omg3(ip2,jp0,kp0) = omg3(ip2,jp0,kp0) + g3*coef
+
+ coef=a2*b0*c1
+ omg1(ip2,jp0,kp1) = omg1(ip2,jp0,kp1) + g1*coef
+ omg2(ip2,jp0,kp1) = omg2(ip2,jp0,kp1) + g2*coef
+ omg3(ip2,jp0,kp1) = omg3(ip2,jp0,kp1) + g3*coef
+
+ coef=a2*b0*c2
+ omg1(ip2,jp0,kp2) = omg1(ip2,jp0,kp2) + g1*coef
+ omg2(ip2,jp0,kp2) = omg2(ip2,jp0,kp2) + g2*coef
+ omg3(ip2,jp0,kp2) = omg3(ip2,jp0,kp2) + g3*coef
+
+ coef=a2*b0*c3
+ omg1(ip2,jp0,kp3) = omg1(ip2,jp0,kp3) + g1*coef
+ omg2(ip2,jp0,kp3) = omg2(ip2,jp0,kp3) + g2*coef
+ omg3(ip2,jp0,kp3) = omg3(ip2,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b1*c0
+ omg1(ip2,jp1,kp0) = omg1(ip2,jp1,kp0) + g1*coef
+ omg2(ip2,jp1,kp0) = omg2(ip2,jp1,kp0) + g2*coef
+ omg3(ip2,jp1,kp0) = omg3(ip2,jp1,kp0) + g3*coef
+
+ coef=a2*b1*c1
+ omg1(ip2,jp1,kp1) = omg1(ip2,jp1,kp1) + g1*coef
+ omg2(ip2,jp1,kp1) = omg2(ip2,jp1,kp1) + g2*coef
+ omg3(ip2,jp1,kp1) = omg3(ip2,jp1,kp1) + g3*coef
+
+ coef=a2*b1*c2
+ omg1(ip2,jp1,kp2) = omg1(ip2,jp1,kp2) + g1*coef
+ omg2(ip2,jp1,kp2) = omg2(ip2,jp1,kp2) + g2*coef
+ omg3(ip2,jp1,kp2) = omg3(ip2,jp1,kp2) + g3*coef
+
+ coef=a2*b1*c3
+ omg1(ip2,jp1,kp3) = omg1(ip2,jp1,kp3) + g1*coef
+ omg2(ip2,jp1,kp3) = omg2(ip2,jp1,kp3) + g2*coef
+ omg3(ip2,jp1,kp3) = omg3(ip2,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b2*c0
+ omg1(ip2,jp2,kp0) = omg1(ip2,jp2,kp0) + g1*coef
+ omg2(ip2,jp2,kp0) = omg2(ip2,jp2,kp0) + g2*coef
+ omg3(ip2,jp2,kp0) = omg3(ip2,jp2,kp0) + g3*coef
+
+ coef=a2*b2*c1
+ omg1(ip2,jp2,kp1) = omg1(ip2,jp2,kp1) + g1*coef
+ omg2(ip2,jp2,kp1) = omg2(ip2,jp2,kp1) + g2*coef
+ omg3(ip2,jp2,kp1) = omg3(ip2,jp2,kp1) + g3*coef
+
+ coef=a2*b2*c2
+ omg1(ip2,jp2,kp2) = omg1(ip2,jp2,kp2) + g1*coef
+ omg2(ip2,jp2,kp2) = omg2(ip2,jp2,kp2) + g2*coef
+ omg3(ip2,jp2,kp2) = omg3(ip2,jp2,kp2) + g3*coef
+
+ coef=a2*b2*c3
+ omg1(ip2,jp2,kp3) = omg1(ip2,jp2,kp3) + g1*coef
+ omg2(ip2,jp2,kp3) = omg2(ip2,jp2,kp3) + g2*coef
+ omg3(ip2,jp2,kp3) = omg3(ip2,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a2*b3*c0
+ omg1(ip2,jp3,kp0) = omg1(ip2,jp3,kp0) + g1*coef
+ omg2(ip2,jp3,kp0) = omg2(ip2,jp3,kp0) + g2*coef
+ omg3(ip2,jp3,kp0) = omg3(ip2,jp3,kp0) + g3*coef
+
+ coef=a2*b3*c1
+ omg1(ip2,jp3,kp1) = omg1(ip2,jp3,kp1) + g1*coef
+ omg2(ip2,jp3,kp1) = omg2(ip2,jp3,kp1) + g2*coef
+ omg3(ip2,jp3,kp1) = omg3(ip2,jp3,kp1) + g3*coef
+
+ coef=a2*b3*c2
+ omg1(ip2,jp3,kp2) = omg1(ip2,jp3,kp2) + g1*coef
+ omg2(ip2,jp3,kp2) = omg2(ip2,jp3,kp2) + g2*coef
+ omg3(ip2,jp3,kp2) = omg3(ip2,jp3,kp2) + g3*coef
+
+ coef=a2*b3*c3
+ omg1(ip2,jp3,kp3) = omg1(ip2,jp3,kp3) + g1*coef
+ omg2(ip2,jp3,kp3) = omg2(ip2,jp3,kp3) + g2*coef
+ omg3(ip2,jp3,kp3) = omg3(ip2,jp3,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b0*c0
+ omg1(ip3,jp0,kp0) = omg1(ip3,jp0,kp0) + g1*coef
+ omg2(ip3,jp0,kp0) = omg2(ip3,jp0,kp0) + g2*coef
+ omg3(ip3,jp0,kp0) = omg3(ip3,jp0,kp0) + g3*coef
+
+ coef=a3*b0*c1
+ omg1(ip3,jp0,kp1) = omg1(ip3,jp0,kp1) + g1*coef
+ omg2(ip3,jp0,kp1) = omg2(ip3,jp0,kp1) + g2*coef
+ omg3(ip3,jp0,kp1) = omg3(ip3,jp0,kp1) + g3*coef
+
+ coef=a3*b0*c2
+ omg1(ip3,jp0,kp2) = omg1(ip3,jp0,kp2) + g1*coef
+ omg2(ip3,jp0,kp2) = omg2(ip3,jp0,kp2) + g2*coef
+ omg3(ip3,jp0,kp2) = omg3(ip3,jp0,kp2) + g3*coef
+
+ coef=a3*b0*c3
+ omg1(ip3,jp0,kp3) = omg1(ip3,jp0,kp3) + g1*coef
+ omg2(ip3,jp0,kp3) = omg2(ip3,jp0,kp3) + g2*coef
+ omg3(ip3,jp0,kp3) = omg3(ip3,jp0,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b1*c0
+ omg1(ip3,jp1,kp0) = omg1(ip3,jp1,kp0) + g1*coef
+ omg2(ip3,jp1,kp0) = omg2(ip3,jp1,kp0) + g2*coef
+ omg3(ip3,jp1,kp0) = omg3(ip3,jp1,kp0) + g3*coef
+
+ coef=a3*b1*c1
+ omg1(ip3,jp1,kp1) = omg1(ip3,jp1,kp1) + g1*coef
+ omg2(ip3,jp1,kp1) = omg2(ip3,jp1,kp1) + g2*coef
+ omg3(ip3,jp1,kp1) = omg3(ip3,jp1,kp1) + g3*coef
+
+ coef=a3*b1*c2
+ omg1(ip3,jp1,kp2) = omg1(ip3,jp1,kp2) + g1*coef
+ omg2(ip3,jp1,kp2) = omg2(ip3,jp1,kp2) + g2*coef
+ omg3(ip3,jp1,kp2) = omg3(ip3,jp1,kp2) + g3*coef
+
+ coef=a3*b1*c3
+ omg1(ip3,jp1,kp3) = omg1(ip3,jp1,kp3) + g1*coef
+ omg2(ip3,jp1,kp3) = omg2(ip3,jp1,kp3) + g2*coef
+ omg3(ip3,jp1,kp3) = omg3(ip3,jp1,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b2*c0
+ omg1(ip3,jp2,kp0) = omg1(ip3,jp2,kp0) + g1*coef
+ omg2(ip3,jp2,kp0) = omg2(ip3,jp2,kp0) + g2*coef
+ omg3(ip3,jp2,kp0) = omg3(ip3,jp2,kp0) + g3*coef
+
+ coef=a3*b2*c1
+ omg1(ip3,jp2,kp1) = omg1(ip3,jp2,kp1) + g1*coef
+ omg2(ip3,jp2,kp1) = omg2(ip3,jp2,kp1) + g2*coef
+ omg3(ip3,jp2,kp1) = omg3(ip3,jp2,kp1) + g3*coef
+
+ coef=a3*b2*c2
+ omg1(ip3,jp2,kp2) = omg1(ip3,jp2,kp2) + g1*coef
+ omg2(ip3,jp2,kp2) = omg2(ip3,jp2,kp2) + g2*coef
+ omg3(ip3,jp2,kp2) = omg3(ip3,jp2,kp2) + g3*coef
+
+ coef=a3*b2*c3
+ omg1(ip3,jp2,kp3) = omg1(ip3,jp2,kp3) + g1*coef
+ omg2(ip3,jp2,kp3) = omg2(ip3,jp2,kp3) + g2*coef
+ omg3(ip3,jp2,kp3) = omg3(ip3,jp2,kp3) + g3*coef
+
+ccc
+
+ coef=a3*b3*c0
+ omg1(ip3,jp3,kp0) = omg1(ip3,jp3,kp0) + g1*coef
+ omg2(ip3,jp3,kp0) = omg2(ip3,jp3,kp0) + g2*coef
+ omg3(ip3,jp3,kp0) = omg3(ip3,jp3,kp0) + g3*coef
+
+ coef=a3*b3*c1
+ omg1(ip3,jp3,kp1) = omg1(ip3,jp3,kp1) + g1*coef
+ omg2(ip3,jp3,kp1) = omg2(ip3,jp3,kp1) + g2*coef
+ omg3(ip3,jp3,kp1) = omg3(ip3,jp3,kp1) + g3*coef
+
+ coef=a3*b3*c2
+ omg1(ip3,jp3,kp2) = omg1(ip3,jp3,kp2) + g1*coef
+ omg2(ip3,jp3,kp2) = omg2(ip3,jp3,kp2) + g2*coef
+ omg3(ip3,jp3,kp2) = omg3(ip3,jp3,kp2) + g3*coef
+
+ coef=a3*b3*c3
+ omg1(ip3,jp3,kp3) = omg1(ip3,jp3,kp3) + g1*coef
+ omg2(ip3,jp3,kp3) = omg2(ip3,jp3,kp3) + g2*coef
+ omg3(ip3,jp3,kp3) = omg3(ip3,jp3,kp3) + g3*coef
+
+ccc
+
+20 CONTINUE
+
+ npart=0
+
+ do k=1,nz
+ z=amod(z0-zmin+(k-1)*dz+zm,zm)+zmin
+ do j=1,ny
+ y=amod(y0-ymin+(j-1)*dy+ym,ym)+ymin
+ do i=1,nx
+ x=amod(x0-xmin+(i-1)*dx+xm,xm)+xmin
+ vol=dx*dy*dz
+ strength=abs(omg1(i,j,k))+abs(omg2(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.ge.circlim*vol)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ dv(npart)=vol
+ om1(npart)=omg1(i,j,k)
+ om2(npart)=omg2(i,j,k)
+ om3(npart)=omg3(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+ if (ipoint.eq.0) go to 310
+
+
+c goto 310
+
+ if (idif.ne.0) then
+
+c dans la foulee on fiat la diffusion dans l'espace
+c mappee avec formules de diffusion anisotropes
+
+c pas de temps de diffusion pour CFL
+
+c coeff aspect ratio pour se mettre dans une grille
+c totalement isotrope et coeff de normalisation
+c pour kernel 1/(1+r**2)
+ dzdx=(dz/dx)**2
+ dzdy=(dz/dy)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+c boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+c boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx-1,nx)+1
+ j2=mod(jj+ly+ny-1,ny)+1
+ k2=mod(kk+lz+nz-1,nz)+1
+ gammasrc1=omg1(i2,j2,k2)
+ gammasrc2=omg2(i2,j2,k2)
+ gammasrc3=omg3(i2,j2,k2)
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ dvx=(vxsrc-vxrcv)/dx
+ dvy=(vysrc-vyrcv)/dy
+ dvz=(vzsrc-vzrcv)/dz
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ ales=amax1(0.,dvx*lx+dvy*ly+dvz*lz)/(1.+r)**2
+c ales=abs(dvx*lx+dvy*ly+dvz*lz)/(1.+r)**2
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ factor=akernel/(dz*dz)
+ tot2=tot2+akernel
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*
+ 1 (anu*factor+coef_les*ales)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*
+ 1 (anu*factor+coef_les*ales)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*
+ 1 (anu*factor+coef_les*ales)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy*dx*dz/dv(i))
+
+c enddo pour caluc de dom sur les particules
+ enddo
+
+
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv(i))
+ omax0=amax1(omax0,abs(om2(i))/dv(i))
+ omax0=amax1(omax0,abs(om3(i))/dv(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv(i))
+ omax1=amax1(omax1,abs(om2(i))/dv(i))
+ omax1=amax1(omax1,abs(om3(i))/dv(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+ endif
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/stream.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/stream.f
new file mode 100644
index 0000000000000000000000000000000000000000..d3dc29b0afe4af520df9bff8032cfd4973b32990
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/stream.f
@@ -0,0 +1,137 @@
+ subroutine stream(iper)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ dimension rhs(npgx,npgy,npgz),bdzs(npgx,npgy),bdzf(npgx,npgy)
+ dimension bdxs(1,1),bdxf(1,1),bdys(npgx,npgz),bdyf(npgx,npgz)
+ dimension w(10000)
+
+ common/stuff/omg1i(npgx,npgy,npgz),
+ 1 omg2i(npgx,npgy,npgz),omg3i(npgx,npgy,npgz),
+ 1 vxgi(npgx,npgy,npgz),vygi(npgx,npgy,npgz),vzgi(npgx,npgy,npgz)
+
+
+c calucl de fonction courants 3d
+
+
+ xs=xmin
+ xf=xmax
+ ys=ymin
+ yf=ymax
+ zs=zmin
+ zf=zmax
+
+
+ w(1)=100000
+ lbdcnd=0
+ mbdcnd=0
+ nbdcnd=0
+ beta=0.
+ ldimf=npgx
+ mdimf=npgy
+ elmbda=0.
+ pertrb=0.
+ ierror=0
+
+ do k=1,nz+1
+ kk=mod(k-1,nz)+1
+ do j=1,ny+1
+ do i=1,nx+1
+ ii=mod(i-1,nx)+1
+ rhs(i,j,k)=-omg1(ii,j,kk)+omg1i(ii,j,kk)
+ enddo
+ enddo
+ enddo
+
+
+ call HW3CRT(XS,XF,nx,LBDCND,BDXS,BDXF,yS,yF,ny,MBDCND,BDYS,
+ 1 BDYF,zS,zF,nz,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,mDIMF,rhs,PERTRB,
+ 2 IERROR,W)
+
+
+ if (ierror.ne.0) print*,'attention sepx ierror=',ierror
+
+ psimax=0.
+ do i=1,nx+1
+ do j=1,ny+1
+ do k=1,nz+1
+ psi1(i,j,k)=rhs(i,j,k)
+ psimax=amax1(psimax,abs(psi1(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+
+c 2e composante:
+
+ do k=1,nz+1
+ kk=mod(k-1,nz)+1
+ do j=1,ny+1
+ do i=1,nx+1
+ ii=mod(i-1,nx)+1
+ rhs(i,j,k)=-omg2(ii,j,kk)+omg2i(ii,j,kk)
+
+ enddo
+ enddo
+ enddo
+
+ w(1)=100000
+
+ call HW3CRT(XS,XF,nx,LBDCND,BDXS,BDXF,yS,yF,ny,MBDCND,BDYS,
+ 1 BDYF,zS,zF,nz,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,mDIMF,rhs,PERTRB,
+ 2 IERROR,W)
+
+
+ if (ierror.ne.0) print*,'attention sepx ierror=',ierror
+
+ psimax=0.
+ psitot=0.
+ do i=1,nx+1
+ do j=1,ny+1
+ do k=1,nz+1
+ psi2(i,j,k)=rhs(i,j,k)
+ psimax=amax1(psimax,abs(psi2(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+
+c 3E composante
+
+ do k=1,nz+1
+ kk=mod(k-1,nz)+1
+ do j=1,ny+1
+ do i=1,nx+1
+ ii=mod(i-1,nx)+1
+ rhs(i,j,k)=-omg3(ii,j,kk)+omg3i(ii,j,kk)
+ enddo
+ enddo
+ enddo
+
+ w(1)=100000
+
+ call HW3CRT(XS,XF,nx,LBDCND,BDXS,BDXF,yS,yF,ny,MBDCND,BDYS,
+ 1 BDYF,zS,zF,nz,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,mDIMF,rhs,PERTRB,
+ 2 IERROR,W)
+
+ if (ierror.ne.0) print*,'attention sepx ierror=',ierror
+
+ psimax=0.
+ do i=1,nx+1
+ do j=1,ny+1
+ yy=float(j-1)*dx
+ do k=1,nz+1
+ psi3(i,j,k)=rhs(i,j,k)
+ psimax=amax1(psimax,abs(psi3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_fft_2ways.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_fft_2ways.f
new file mode 100644
index 0000000000000000000000000000000000000000..3059dbf43715ce2cf9cf8efb4c3bdb9b0d82d3bb
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_fft_2ways.f
@@ -0,0 +1,127 @@
+ subroutine velox_fft
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension aux3(npg,npg,npg),aux1(npg,npg,npg),aux2(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),
+ 1 wk(ngx2+1,npgy,npgz)
+
+ pi=3.1415926
+ dxinv=0.5/dx
+ dyinv=dxinv
+ dzinv=dxinv
+
+c calucl de fonction courants 3d
+
+ nx2=nx/2
+ ny2=ny/2
+ nz2=nz/2
+
+
+ call fftw3d(omg1,cfx,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg2,cfy,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg3,cfz,nx,ny,nz,nx2,ny2,nz2,wk,0)
+
+
+c coeff de normalisation pour laplacien en spectral
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nz2,nz2
+ rk=float(k)*ak
+ do 10 j=1-ny2,ny2
+ rj=float(j)*aj
+ do 10 i=0,nx2
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+ if (r2.ne.0.) then
+c
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ endif
+10 continue
+
+
+ call fftw3d(aux1,cux,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,cuy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,cuz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+ goto 111
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ dvx(i,j,k)=(-aux1(i,j,k)-vxg(i,j,k))/delt
+ dvy(i,j,k)=(-aux2(i,j,k)-vyg(i,j,k))/delt
+ dvz(i,j,k)=(-aux2(i,j,k)-vzg(i,j,k))/delt
+
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+c pour terme barotrope : du/dt+(u\nabla)u - g =
+ do k=1,nz
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do i=1,nx
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ dvx(i,j,k)=dvx(i,j,k)+vxg(i,j,k)*(vxg(it,j,k)-vxg(ib,j,k))*dxinv
+ dvx(i,j,k)=dvx(i,j,k)+vyg(i,j,k)*(vxg(i,jt,k)-vxg(i,jb,k))*dyinv
+ dvx(i,j,k)=dvx(i,j,k)+vzg(i,j,k)*(vxg(i,j,kt)-vxg(i,j,kb))*dyinv
+ dvy(i,j,k)=dvy(i,j,k)+vxg(i,j,k)*(vyg(it,j,k)-vyg(ib,j,k))*dxinv
+ dvy(i,j,k)=dvy(i,j,k)+vyg(i,j,k)*(vyg(i,jt,k)-vyg(i,jb,k))*dyinv
+ dvy(i,j,k)=dvy(i,j,k)+vzg(i,j,k)*(vyg(i,j,kt)-vyg(i,j,kb))*dyinv
+ dvz(i,j,k)=dvz(i,j,k)+vxg(i,j,k)*(vzg(it,j,k)-vzg(ib,j,k))*dxinv
+ dvz(i,j,k)=dvz(i,j,k)+vyg(i,j,k)*(vzg(i,jt,k)-vzg(i,jb,k))*dyinv
+ dvz(i,j,k)=dvz(i,j,k)+vzg(i,j,k)*(vzg(i,j,kt)-vzg(i,j,kb))*dyinv
+
+ enddo
+ enddo
+ enddo
+
+111 continue
+
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_stream.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_stream.f
new file mode 100644
index 0000000000000000000000000000000000000000..0f831ead235a72f973419fb51ba994ac0bbf4822
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/velox_stream.f
@@ -0,0 +1,52 @@
+ subroutine velox_stream
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ integer indxg(npgx,npgy),indyg(npgx,npgy)
+
+
+
+ dxinv2=0.5/dx
+ dyinv2=0.5/dy
+ dzinv2=0.5/dz
+
+ vnmax=0.
+ vxmin=1000.
+ vxmax=-1000.
+ vymin=100.
+ vymax=-1000.
+ do k=1,nz
+ kt=mod(k,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ do j=1,ny
+ jt=mod(j,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do i=1,nx
+ it=mod(i,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ vxg(i,j,k)=(-psi3(i,jb,k)+psi3(i,jt,k))*dyinv2-
+ 1 (-psi2(i,j,kb)+psi2(i,j,kt))*dzinv2
+
+ vyg(i,j,k)=(-psi1(i,j,kb)+psi1(i,j,kt))*dzinv2-
+ 1 (-psi3(ib,j,k)+psi3(it,j,k))*dxinv2
+
+ vzg(i,j,k)=(-psi2(ib,j,k)+psi2(it,j,k))*dxinv2-
+ 1 (-psi1(i,jb,k)+psi1(i,jt,k))*dyinv2
+
+ vymax=amax1(vymax,(vyg(i,j,k)))
+ vymin=amin1(vymin,(vyg(i,j,k)))
+ vxmax=amax1(vxmax,(vxg(i,j,k)))
+ vxmin=amin1(vxmin,(vxg(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+c print*,' VXMAX = ',vxmax,vymax
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/NotUsed/vhat.f b/CodesEnVrac/CodeGH/src-sphere/NotUsed/vhat.f
new file mode 100644
index 0000000000000000000000000000000000000000..f634056c4ce556c0a27f5743749a199d38f73294
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/NotUsed/vhat.f
@@ -0,0 +1,51 @@
+ subroutine vhat(delt)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ pi=3.1415926
+ topi=2./pi
+ eps=dx/1000.
+
+c calcul vitesse moyenne dans obstacle
+
+ total=0.
+ aux=0.
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ arg=phig(i,j,k)
+ aux=aux+arg*vzg(i,j,k)
+ total=total+arg
+ enddo
+ enddo
+ enddo
+
+
+ aux=aux/total
+
+ do i=1,nx
+ do j=1,ny
+ do k=1,nz
+ dvx(i,j,k)=0.
+ dvy(i,j,k)=0.
+ dvz(i,j,k)=(aux-vzh)/delt
+ enddo
+ enddo
+ enddo
+
+ vzh=aux
+
+ zg=zg+delt*vzh
+
+101 continue
+
+
+ return
+ end
+
+
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/arrays.h b/CodesEnVrac/CodeGH/src-sphere/arrays.h
new file mode 100644
index 0000000000000000000000000000000000000000..b76a59abe81a0f7d224df797944bc289d4720e43
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/arrays.h
@@ -0,0 +1,7 @@
+common /GRID/ &
+omg1(npgx,npgy,npgz),omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),&
+ vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),&
+ psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),&
+ strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),&
+ strg3(npgx,npgy,npgz),phig(npgx,npgy,npgz)
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/dif_om.f90 b/CodesEnVrac/CodeGH/src-sphere/dif_om.f90
new file mode 100644
index 0000000000000000000000000000000000000000..547622cd4d28c9a494681ec2d31932d1105ca715
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/dif_om.f90
@@ -0,0 +1,73 @@
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE dif_om(npart,om1,om2,om3,xp1,yp1,zp1,dv1,anu,dt,omax2)
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+!
+! diffusion sur grille puis initialisation des particules
+!
+
+!----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ anudt=anu*dt/(dx**2)
+
+ circlim=0.001
+
+ omax1=0.
+ omax2=0.
+
+ do k=1,nz
+ kt=mod(k,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ do j=1,ny
+ jt=mod(j,nz)+1
+ jb=mod(j-2+nz,nz)+1
+ do i=1,nx
+ it=mod(i,nz)+1
+ ib=mod(i-2+nz,nz)+1
+ psi1(i,j,k)=omg1(it,j,k)+omg1(ib,j,k)+omg1(i,jt,k)+omg1(i,jb,k)+omg1(i,j,kt)+omg1(i,j,kb)-6.*omg1(i,j,k)
+ psi2(i,j,k)=omg2(it,j,k)+omg2(ib,j,k)+omg2(i,jt,k)+omg2(i,jb,k)+omg2(i,j,kt)+omg2(i,j,kb)-6.*omg2(i,j,k)
+ psi3(i,j,k)=omg3(it,j,k)+omg3(ib,j,k)+omg3(i,jt,k)+omg3(i,jb,k)+omg3(i,j,kt)+omg3(i,j,kb)-6.*omg3(i,j,k)
+ omax1=amax1(omax1,abs(omg1(i,j,k)))
+ omax1=amax1(omax1,abs(omg2(i,j,k)))
+ omax1=amax1(omax1,abs(omg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ npart=0
+ vol=dx**3
+ do k=1,nz
+ z=zmin+(k-1)*dz
+ do j=1,ny
+ y=ymin+(j-1)*dy
+ do i=1,nx
+ x=xmin+(i-1)*dx
+ omg1(i,j,k)=omg1(i,j,k)+anudt*psi1(i,j,k)
+ omg2(i,j,k)=omg2(i,j,k)+anudt*psi2(i,j,k)
+ omg3(i,j,k)=omg3(i,j,k)+anudt*psi3(i,j,k)
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ omax2=amax1(omax2,abs(omg1(i,j,k)))
+ omax2=amax1(omax2,abs(omg2(i,j,k)))
+ omax2=amax1(omax2,abs(omg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'OMAX avant et apres DIFF ',omax1,omax2
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/diff_fft.f90 b/CodesEnVrac/CodeGH/src-sphere/diff_fft.f90
new file mode 100644
index 0000000000000000000000000000000000000000..60fd7d07c4a134598d0be5ea750919cde77e29e6
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/diff_fft.f90
@@ -0,0 +1,114 @@
+subroutine diff_fft(npart,anu,delt,xp1,yp1,zp1,om1,om2,om3,dv1,omax2)
+
+ ! calcul fft pour vitesses ET diffusion
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+
+ dimension aux3(npg,npg,npg),aux1(npg,npg,npg),aux2(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,cox,coy,coz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cox(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ wk(ngx2+1,npgy,npgz)
+
+ pi=3.1415926
+ dxinv=0.5/dx
+ dyinv=dxinv
+ dzinv=dxinv
+
+ ! calucl de fonction courants 3d
+
+ nx2=nx/2
+ ny2=ny/2
+ nz2=nz/2
+
+
+ call fftw3d(omg1,cfx,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg2,cfy,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg3,cfz,nx,ny,nz,nx2,ny2,nz2,wk,0)
+
+
+ ! coeff de normalisation pour laplacien en spectral
+
+ anudt=anu*delt
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nz2,nz2
+ rk=float(k)*ak
+ do 10 j=1-ny2,ny2
+ rj=float(j)*aj
+ do 10 i=0,nx2
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ r2b=(1.+r2*anudt)
+ ! diffusion en fourier
+ cox(i,j,k)=cfx(i,j,k)/r2b
+ coy(i,j,k)=cfy(i,j,k)/r2b
+ coz(i,j,k)=cfz(i,j,k)/r2b
+10 continue
+
+
+ ! fourier inverse pour vorticite apres difusion
+ ! et creation de particules
+
+ call fftw3d(aux1,cox,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,coy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,coz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+
+ circlim=0.0001
+ npart=0
+ vol=dx**3
+ omax1=0.
+ omax2=0.
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ omg1(i,j,k)=aux1(i,j,k)
+ omg2(i,j,k)=aux2(i,j,k)
+ omg3(i,j,k)=aux3(i,j,k)
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ x=xmin+float(i-1)*dx
+ y=xmin+float(j-1)*dx
+ z=xmin+float(k-1)*dx
+ npart=npart+1
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ omax2=amax1(omax2,abs(omg1(i,j,k)))
+ omax2=amax1(omax2,abs(omg2(i,j,k)))
+ omax2=amax1(omax2,abs(omg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'OMAX avant et apres DIFF ',omax1,omax2
+ return
+
+
+end subroutine diff_fft
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/drag.f90 b/CodesEnVrac/CodeGH/src-sphere/drag.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bba1137fdf135ac5e2283733445926671840ea3e
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/drag.f90
@@ -0,0 +1,28 @@
+ subroutine drag(drag1,drag2,drag3,j1,j2)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ drag1=0.
+ drag2=0.
+ drag3=0.
+ do i=1,nx
+ DO j=j1,j2-1
+ yy=ymin+(float(j)-1.)*dy
+ DO k=1,nz
+ zz=zmin+(float(k)-1.)*dz
+ drag1=drag1+vxg(i,j,k)*(1.-phig(i,j,k))
+ drag2=drag2+(zz*omg2(i,j,k)-yy*omg3(i,j,k))*(1.-phig(i,j,k))
+ drag3=drag3+vxg(i,j,k)*phig(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ drag1=drag1*dx*dx*dx
+ drag2=drag2*dx*dx*dx
+ drag3=drag3*dx*dx*dx
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/drag_surface.f90 b/CodesEnVrac/CodeGH/src-sphere/drag_surface.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e9ece0ada5ce1037dd338ed148503cc914c8c84f
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/drag_surface.f90
@@ -0,0 +1,104 @@
+subroutine drag_surface(drag,anu,j1,j2)
+
+! calcul de force selon x (pour drag)
+! termes de surfaces en y= j1 et y=j2 pour la fromule de noca
+! poru le drag, en supposant omega = O sur le faces z=+-h
+! par rapport a noca : facteur 1/2 a mettre en facteur du tout
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ pi=3.1415926
+
+ j1t=mod(j1+ny,ny)+1
+ j1b=mod(j1-2+ny,ny)+1
+ j2t=mod(j2+ny,ny)+1
+ j2b=mod(j2-2+ny,ny)+1
+ y1=ymin+float(j1-1)*dx
+ y2=ymin+float(j2-1)*dx
+ drag1=0.
+ drag2=0.
+ drag3=0.
+ drag4=0.
+ drag5=0.
+! faces y=cste (j1 ou j2)
+ do i=1,nx
+ ii=mod(i-1+nx,nx)+1
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ x=xmin+float(i-1)*dx
+ DO k=1,nz
+ kk=mod(k-1+nz,nz)+1
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ z=xmin+float(k-1)*dx
+! queqlues derivees aparaissant dans certines integrales
+! de surface
+ dux1dy=vxg(ii,j1t,kk)-vxg(ii,j1b,kk)
+ duy1dx=vyg(it,j1,kk)-vyg(ib,j1,kk)
+ dux2dy=vxg(ii,j2t,kk)-vxg(ii,j2b,kk)
+ duy2dx=vyg(it,j2,kk)-vyg(ib,j2,kk)
+ deltaux1=vxg(it,j1,kk)+vxg(ib,j1,kk)+vxg(ii,j1t,kk)+&
+ vxg(ii,j1b,kk)+vxg(ii,j1,kt)+vxg(ii,j1,kb)-6.*vxg(ii,j1,kk)
+ deltaux2=vxg(it,j2,kk)+vxg(ib,j2,kk)+vxg(ii,j2t,kk)+&
+ vxg(ii,j2b,kk)+vxg(ii,j2,kt)+vxg(ii,j2,kb)-6.*vxg(ii,j2,kk)
+! 1ere
+ drag1=drag1+2.*vyg(ii,j1,kk)*vxg(ii,j1,kk)
+ drag1=drag1-2.*vyg(ii,j2,kk)*vxg(ii,j2,kk)
+! 2e
+ drag2=drag2+vyg(ii,j1,kk)*&
+ (y1*omg3(ii,j1,kk)-z*omg2(ii,j1,kk))
+ drag2=drag2-vyg(ii,j2,kk)*&
+ (y2*omg3(ii,j2,kk)-z*omg2(ii,j2,kk))
+! 3e
+ drag3=drag3-omg2(ii,j1,kk)*&
+ (y1*vzg(ii,j1,kk)-z*vyg(ii,j1,kk))
+ drag3=drag3+omg2(ii,j2,kk)*&
+ (y2*vzg(ii,j2,kk)-z*vyg(ii,j2,kk))
+! 4e
+ drag4=drag4+y1*anu*deltaux1/(dx**2)
+ drag4=drag4-y2*anu*deltaux2/(dx**2)
+! 5e (attention facteur 2 par raport aux autres -> 2dx devient dx)
+ drag5=drag5-anu*(dux1dy+duy1dx)/(dx)
+ drag5=drag5+anu*(dux2dy+duy2dx)/(dx)
+ enddo
+ enddo
+
+! faces z=0 et z=1 pour 2e,3e et4e integrale
+ drag2b=0.
+ drag3b=0.
+ drag4b=0.
+ do i=1,nx
+ ii=mod(i-1+nx,nx)+1
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ x=xmin+float(i-1)*dx
+ do j=j1,j2-1
+ jt=mod(j+nz,nz)+1
+ jb=mod(j-2+nz,nz)+1
+! queqlues derivees aparaissant dans certines integrales
+! de surface
+ deltaux1=vxg(it,j,1)+vxg(ib,j,1)+vxg(ii,jt,1)+&
+ vxg(ii,jb,1)+vxg(ii,j,2)+vxg(ii,j,nx)-6.*vxg(ii,j,1)
+! 2e integrale
+ drag2b=drag2b+(xmax-xmin)*vzg(ii,j,1)*omg2(ii,j,1)
+! 3e intergral
+ drag3b=drag3b-(xmax-xmin)*vyg(ii,j,1)*omg3(ii,j,1)
+! 4e
+ drag4b=drag4b-(xmax-xmin)*anu*deltaux1/(dx**2)
+ enddo
+ enddo
+
+ drag=drag1+drag2+drag3+drag4+drag5+drag2b+drag3b+drag4b
+
+ drag=drag*dx*dx
+
+ cc=4.*dx*dx/(pi*0.2422*0.2422)
+
+ print*,'DRAGSSS ',cc*drag1,cc*drag2,cc*drag3,cc*drag4,cc*drag5
+ print*,'DRAGSSS ',cc*drag2b,cc*drag3b,cc*drag4b
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/init.f90 b/CodesEnVrac/CodeGH/src-sphere/init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..77b19bc6c3c6008566a152f45740a9a81b10aed9
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/init.f90
@@ -0,0 +1,63 @@
+ subroutine init(npart,xp,yp,zp,omx,omy,omz,dv)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp(*),yp(*),zp(*),dv(*)
+ dimension omx(*),omy(*),omz(*)
+
+ character*30 rota
+
+ pi=3.1415926
+ piinv = 1./( pi)
+ pi2=2.*pi
+
+ xc=(xmin+xmax)/2.
+ yc=xc
+ zc=xc
+! rc1=0.1
+ rc1=(xmax-xmin)*0.1211
+
+ eps=dx*width
+
+ npart=0.
+ do 10 i=1,nx
+ xx=xmin+(float(i)-1.)*dx
+ DO 10 j=1,ny
+ yy=ymin+(float(j)-1.)*dy
+ DO 10 k=1,nz
+ zz=zmin+(float(k)-1.)*dz
+ npart=npart+1
+ r1 =sqrt((xx-xc)**2+(yy-yc)**2+(zz-zc)**2)-rc1
+ xp(npart)=xx
+ yp(npart)=yy
+ zp(npart)=zz
+ dv(npart)=dx*dy*dz
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+ vxg(i,j,k)=0.
+ vyg(i,j,k)=0.
+ vzg(i,j,k)=0.
+ strg1(i,j,k)=0.
+ strg2(i,j,k)=0.
+ strg3(i,j,k)=0.
+ omx(npart)=0.
+ omy(npart)=0.
+ omz(npart)=0.
+ phig(i,j,k)=amin1(1.,amax1(1.-r1/eps,0.))
+ if ((j.le.4).or.(j.ge.nx-3)) phig(i,j,k)=1.
+10 continue
+ print*, 'NPART =', npart
+
+101 continue
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/intersm4.f90 b/CodesEnVrac/CodeGH/src-sphere/intersm4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0241ebbdf6a3f825da0024cf82ecf84047f5c6e3
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/intersm4.f90
@@ -0,0 +1,365 @@
+!
+SUBROUTINE intersm4(npart,g1,g2,g3,xp,yp,zp)
+
+ !
+ ! Interpolation routine with M'4
+ !
+ ! geometry=unit box, periodic in x and y
+ ! last ponits in z direction assume extension by continuity
+ ! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+ include 'param.i'
+ include 'param.h'
+ dimension g1(1),g2(1),g3(1),xp(1),yp(1),zp(1)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),&
+ omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),&
+ vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),&
+ psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),&
+ gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),&
+ phig(npgx,npgy,npgz)
+
+ do i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+ end do
+
+ dxinv=1./dx
+ dyinv=1./dy
+ dzinv=1./dz
+ dh3=dx*dy*dz
+ dhinv3=1./dh3
+
+
+ !--------------------------------------------------------------------
+ !- PART II : Determination of the circulation of each particle
+ !--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ DO i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+
+ ! get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dy-y0)*dyinv
+ zz1 = (z - float(kp1)*dz-z0)*dzinv
+ xx0=xx1+1
+ yy0=yy1+1
+ zz0=zz1+1
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+ xx3=2-xx1
+ yy3=2-yy1
+ zz3=2-zz1
+
+
+ !
+ ! on repositionne les points de grille par periodicite
+ ! entre 0 et m-1, puis on numerote de 1 a m
+ !
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+
+ ! print*,ip0,ip1,ip2,ip3
+
+ jp1=mod(jp1+ny,ny) +1
+ jp0=mod(jp0+ny,ny) +1
+ jp2=mod(jp2+ny,ny) +1
+ jp3=mod(jp3+ny,ny) +1
+
+ kp1=mod(kp1+nz,nz) +1
+ kp0=mod(kp0+nz,nz) +1
+ kp2=mod(kp2+nz,nz) +1
+ kp3=mod(kp3+nz,nz) +1
+ !
+ ! The M'4 scheme
+ !
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp0)*a0*b0*c0
+ g1(i)= g1(i) + GG1(ip0,jp1,kp0)*a0*b1*c0
+ g1(i)= g1(i) + GG1(ip0,jp2,kp0)*a0*b2*c0
+ g1(i)= g1(i) + GG1(ip0,jp3,kp0)*a0*b3*c0
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp0)*a0*b0*c0
+ g2(i)= g2(i) + GG2(ip0,jp1,kp0)*a0*b1*c0
+ g2(i)= g2(i) + GG2(ip0,jp2,kp0)*a0*b2*c0
+ g2(i)= g2(i) + GG2(ip0,jp3,kp0)*a0*b3*c0
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp0)*a0*b0*c0
+ g3(i)= g3(i) + GG3(ip0,jp1,kp0)*a0*b1*c0
+ g3(i)= g3(i) + GG3(ip0,jp2,kp0)*a0*b2*c0
+ g3(i)= g3(i) + GG3(ip0,jp3,kp0)*a0*b3*c0
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp0)*a1*b0*c0
+ g1(i)= g1(i) + GG1(ip1,jp1,kp0)*a1*b1*c0
+ g1(i)= g1(i) + GG1(ip1,jp2,kp0)*a1*b2*c0
+ g1(i)= g1(i) + GG1(ip1,jp3,kp0)*a1*b3*c0
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp0)*a1*b0*c0
+ g2(i)= g2(i) + GG2(ip1,jp1,kp0)*a1*b1*c0
+ g2(i)= g2(i) + GG2(ip1,jp2,kp0)*a1*b2*c0
+ g2(i)= g2(i) + GG2(ip1,jp3,kp0)*a1*b3*c0
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp0)*a1*b0*c0
+ g3(i)= g3(i) + GG3(ip1,jp1,kp0)*a1*b1*c0
+ g3(i)= g3(i) + GG3(ip1,jp2,kp0)*a1*b2*c0
+ g3(i)= g3(i) + GG3(ip1,jp3,kp0)*a1*b3*c0
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp0)*a2*b0*c0
+ g1(i)= g1(i) + GG1(ip2,jp1,kp0)*a2*b1*c0
+ g1(i)= g1(i) + GG1(ip2,jp2,kp0)*a2*b2*c0
+ g1(i)= g1(i) + GG1(ip2,jp3,kp0)*a2*b3*c0
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp0)*a2*b0*c0
+ g2(i)= g2(i) + GG2(ip2,jp1,kp0)*a2*b1*c0
+ g2(i)= g2(i) + GG2(ip2,jp2,kp0)*a2*b2*c0
+ g2(i)= g2(i) + GG2(ip2,jp3,kp0)*a2*b3*c0
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp0)*a2*b0*c0
+ g3(i)= g3(i) + GG3(ip2,jp1,kp0)*a2*b1*c0
+ g3(i)= g3(i) + GG3(ip2,jp2,kp0)*a2*b2*c0
+ g3(i)= g3(i) + GG3(ip2,jp3,kp0)*a2*b3*c0
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp0)*a3*b0*c0
+ g1(i)= g1(i) + GG1(ip3,jp1,kp0)*a3*b1*c0
+ g1(i)= g1(i) + GG1(ip3,jp2,kp0)*a3*b2*c0
+ g1(i)= g1(i) + GG1(ip3,jp3,kp0)*a3*b3*c0
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp0)*a3*b0*c0
+ g2(i)= g2(i) + GG2(ip3,jp1,kp0)*a3*b1*c0
+ g2(i)= g2(i) + GG2(ip3,jp2,kp0)*a3*b2*c0
+ g2(i)= g2(i) + GG2(ip3,jp3,kp0)*a3*b3*c0
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp0)*a3*b0*c0
+ g3(i)= g3(i) + GG3(ip3,jp1,kp0)*a3*b1*c0
+ g3(i)= g3(i) + GG3(ip3,jp2,kp0)*a3*b2*c0
+ g3(i)= g3(i) + GG3(ip3,jp3,kp0)*a3*b3*c0
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp1)*a0*b0*c1
+ g1(i)= g1(i) + GG1(ip0,jp1,kp1)*a0*b1*c1
+ g1(i)= g1(i) + GG1(ip0,jp2,kp1)*a0*b2*c1
+ g1(i)= g1(i) + GG1(ip0,jp3,kp1)*a0*b3*c1
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp1)*a0*b0*c1
+ g2(i)= g2(i) + GG2(ip0,jp1,kp1)*a0*b1*c1
+ g2(i)= g2(i) + GG2(ip0,jp2,kp1)*a0*b2*c1
+ g2(i)= g2(i) + GG2(ip0,jp3,kp1)*a0*b3*c1
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp1)*a0*b0*c1
+ g3(i)= g3(i) + GG3(ip0,jp1,kp1)*a0*b1*c1
+ g3(i)= g3(i) + GG3(ip0,jp2,kp1)*a0*b2*c1
+ g3(i)= g3(i) + GG3(ip0,jp3,kp1)*a0*b3*c1
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp1)*a1*b0*c1
+ g1(i)= g1(i) + GG1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + GG1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + GG1(ip1,jp3,kp1)*a1*b3*c1
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp1)*a1*b0*c1
+ g2(i)= g2(i) + GG2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + GG2(ip1,jp2,kp1)*a1*b2*c1
+ g2(i)= g2(i) + GG2(ip1,jp3,kp1)*a1*b3*c1
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp1)*a1*b0*c1
+ g3(i)= g3(i) + GG3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + GG3(ip1,jp2,kp1)*a1*b2*c1
+ g3(i)= g3(i) + GG3(ip1,jp3,kp1)*a1*b3*c1
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp1)*a2*b0*c1
+ g1(i)= g1(i) + GG1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + GG1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + GG1(ip2,jp3,kp1)*a2*b3*c1
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp1)*a2*b0*c1
+ g2(i)= g2(i) + GG2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + GG2(ip2,jp2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + GG2(ip2,jp3,kp1)*a2*b3*c1
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp1)*a2*b0*c1
+ g3(i)= g3(i) + GG3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + GG3(ip2,jp2,kp1)*a2*b2*c1
+ g3(i)= g3(i) + GG3(ip2,jp3,kp1)*a2*b3*c1
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp1)*a3*b0*c1
+ g1(i)= g1(i) + GG1(ip3,jp1,kp1)*a3*b1*c1
+ g1(i)= g1(i) + GG1(ip3,jp2,kp1)*a3*b2*c1
+ g1(i)= g1(i) + GG1(ip3,jp3,kp1)*a3*b3*c1
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp1)*a3*b0*c1
+ g2(i)= g2(i) + GG2(ip3,jp1,kp1)*a3*b1*c1
+ g2(i)= g2(i) + GG2(ip3,jp2,kp1)*a3*b2*c1
+ g2(i)= g2(i) + GG2(ip3,jp3,kp1)*a3*b3*c1
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp1)*a3*b0*c1
+ g3(i)= g3(i) + GG3(ip3,jp1,kp1)*a3*b1*c1
+ g3(i)= g3(i) + GG3(ip3,jp2,kp1)*a3*b2*c1
+ g3(i)= g3(i) + GG3(ip3,jp3,kp1)*a3*b3*c1
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp2)*a0*b0*c2
+ g1(i)= g1(i) + GG1(ip0,jp1,kp2)*a0*b1*c2
+ g1(i)= g1(i) + GG1(ip0,jp2,kp2)*a0*b2*c2
+ g1(i)= g1(i) + GG1(ip0,jp3,kp2)*a0*b3*c2
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp2)*a0*b0*c2
+ g2(i)= g2(i) + GG2(ip0,jp1,kp2)*a0*b1*c2
+ g2(i)= g2(i) + GG2(ip0,jp2,kp2)*a0*b2*c2
+ g2(i)= g2(i) + GG2(ip0,jp3,kp2)*a0*b3*c2
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp2)*a0*b0*c2
+ g3(i)= g3(i) + GG3(ip0,jp1,kp2)*a0*b1*c2
+ g3(i)= g3(i) + GG3(ip0,jp2,kp2)*a0*b2*c2
+ g3(i)= g3(i) + GG3(ip0,jp3,kp2)*a0*b3*c2
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp2)*a1*b0*c2
+ g1(i)= g1(i) + GG1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + GG1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + GG1(ip1,jp3,kp2)*a1*b3*c2
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp2)*a1*b0*c2
+ g2(i)= g2(i) + GG2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + GG2(ip1,jp2,kp2)*a1*b2*c2
+ g2(i)= g2(i) + GG2(ip1,jp3,kp2)*a1*b3*c2
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp2)*a1*b0*c2
+ g3(i)= g3(i) + GG3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + GG3(ip1,jp2,kp2)*a1*b2*c2
+ g3(i)= g3(i) + GG3(ip1,jp3,kp2)*a1*b3*c2
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp2)*a2*b0*c2
+ g1(i)= g1(i) + GG1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + GG1(ip2,jp2,kp2)*a2*b2*c2
+ g1(i)= g1(i) + GG1(ip2,jp3,kp2)*a2*b3*c2
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp2)*a2*b0*c2
+ g2(i)= g2(i) + GG2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + GG2(ip2,jp2,kp2)*a2*b2*c2
+ g2(i)= g2(i) + GG2(ip2,jp3,kp2)*a2*b3*c2
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp2)*a2*b0*c2
+ g3(i)= g3(i) + GG3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + GG3(ip2,jp2,kp2)*a2*b2*c2
+ g3(i)= g3(i) + GG3(ip2,jp3,kp2)*a2*b3*c2
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp2)*a3*b0*c2
+ g1(i)= g1(i) + GG1(ip3,jp1,kp2)*a3*b1*c2
+ g1(i)= g1(i) + GG1(ip3,jp2,kp2)*a3*b2*c2
+ g1(i)= g1(i) + GG1(ip3,jp3,kp2)*a3*b3*c2
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp2)*a3*b0*c2
+ g2(i)= g2(i) + GG2(ip3,jp1,kp2)*a3*b1*c2
+ g2(i)= g2(i) + GG2(ip3,jp2,kp2)*a3*b2*c2
+ g2(i)= g2(i) + GG2(ip3,jp3,kp2)*a3*b3*c2
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp2)*a3*b0*c2
+ g3(i)= g3(i) + GG3(ip3,jp1,kp2)*a3*b1*c2
+ g3(i)= g3(i) + GG3(ip3,jp2,kp2)*a3*b2*c2
+ g3(i)= g3(i) + GG3(ip3,jp3,kp2)*a3*b3*c2
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp3)*a0*b0*c3
+ g1(i)= g1(i) + GG1(ip0,jp1,kp3)*a0*b1*c3
+ g1(i)= g1(i) + GG1(ip0,jp2,kp3)*a0*b2*c3
+ g1(i)= g1(i) + GG1(ip0,jp3,kp3)*a0*b3*c3
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp3)*a0*b0*c3
+ g2(i)= g2(i) + GG2(ip0,jp1,kp3)*a0*b1*c3
+ g2(i)= g2(i) + GG2(ip0,jp2,kp3)*a0*b2*c3
+ g2(i)= g2(i) + GG2(ip0,jp3,kp3)*a0*b3*c3
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp3)*a0*b0*c3
+ g3(i)= g3(i) + GG3(ip0,jp1,kp3)*a0*b1*c3
+ g3(i)= g3(i) + GG3(ip0,jp2,kp3)*a0*b2*c3
+ g3(i)= g3(i) + GG3(ip0,jp3,kp3)*a0*b3*c3
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp3)*a1*b0*c3
+ g1(i)= g1(i) + GG1(ip1,jp1,kp3)*a1*b1*c3
+ g1(i)= g1(i) + GG1(ip1,jp2,kp3)*a1*b2*c3
+ g1(i)= g1(i) + GG1(ip1,jp3,kp3)*a1*b3*c3
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp3)*a1*b0*c3
+ g2(i)= g2(i) + GG2(ip1,jp1,kp3)*a1*b1*c3
+ g2(i)= g2(i) + GG2(ip1,jp2,kp3)*a1*b2*c3
+ g2(i)= g2(i) + GG2(ip1,jp3,kp3)*a1*b3*c3
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp3)*a1*b0*c3
+ g3(i)= g3(i) + GG3(ip1,jp1,kp3)*a1*b1*c3
+ g3(i)= g3(i) + GG3(ip1,jp2,kp3)*a1*b2*c3
+ g3(i)= g3(i) + GG3(ip1,jp3,kp3)*a1*b3*c3
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp3)*a2*b0*c3
+ g1(i)= g1(i) + GG1(ip2,jp1,kp3)*a2*b1*c3
+ g1(i)= g1(i) + GG1(ip2,jp2,kp3)*a2*b2*c3
+ g1(i)= g1(i) + GG1(ip2,jp3,kp3)*a2*b3*c3
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp3)*a2*b0*c3
+ g2(i)= g2(i) + GG2(ip2,jp1,kp3)*a2*b1*c3
+ g2(i)= g2(i) + GG2(ip2,jp2,kp3)*a2*b2*c3
+ g2(i)= g2(i) + GG2(ip2,jp3,kp3)*a2*b3*c3
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp3)*a2*b0*c3
+ g3(i)= g3(i) + GG3(ip2,jp1,kp3)*a2*b1*c3
+ g3(i)= g3(i) + GG3(ip2,jp2,kp3)*a2*b2*c3
+ g3(i)= g3(i) + GG3(ip2,jp3,kp3)*a2*b3*c3
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp3)*a3*b0*c3
+ g1(i)= g1(i) + GG1(ip3,jp1,kp3)*a3*b1*c3
+ g1(i)= g1(i) + GG1(ip3,jp2,kp3)*a3*b2*c3
+ g1(i)= g1(i) + GG1(ip3,jp3,kp3)*a3*b3*c3
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp3)*a3*b0*c3
+ g2(i)= g2(i) + GG2(ip3,jp1,kp3)*a3*b1*c3
+ g2(i)= g2(i) + GG2(ip3,jp2,kp3)*a3*b2*c3
+ g2(i)= g2(i) + GG2(ip3,jp3,kp3)*a3*b3*c3
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp3)*a3*b0*c3
+ g3(i)= g3(i) + GG3(ip3,jp1,kp3)*a3*b1*c3
+ g3(i)= g3(i) + GG3(ip3,jp2,kp3)*a3*b2*c3
+ g3(i)= g3(i) + GG3(ip3,jp3,kp3)*a3*b3*c3
+
+ end DO
+
+end SUBROUTINE intersm4
diff --git a/CodesEnVrac/CodeGH/src-sphere/intervm4.f90 b/CodesEnVrac/CodeGH/src-sphere/intervm4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..61456d17c37346172e7e5f9bdb7a9d729ab51365
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/intervm4.f90
@@ -0,0 +1,377 @@
+!
+ SUBROUTINE intervm4(npart,g1,g2,g3,xp,yp,zp)
+
+!
+! Interpolation routine with M'4
+!
+! geometry=unit box, periodic in x and y
+! last ponits in z direction assume extension by continuity
+! that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+!----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension g1(*),g2(*),g3(*),xp(*),yp(*),zp(*)
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),&
+ omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),&
+ gg1(npgx,npgy,npgz),gg2(npgx,npgy,npgz),gg3(npgx,npgy,npgz),&
+ psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),&
+ strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),&
+ strg3(npgx,npgy,npgz),phig(npgx,npgy,npgz)
+
+
+
+ do 10 i=1,npart
+ g1(i)=0.
+ g2(i)=0.
+ g3(i)=0.
+10 continue
+
+ dxinv=1./dx
+ dyinv=1./dy
+ dzinv=1./dz
+ dh3=dx*dy*dz
+ dhinv3=1./dh3
+
+
+!--------------------------------------------------------------------
+!- PART II : Determination of the circulation of each particle
+!--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+ y = YP(i)
+ z = ZP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+
+! get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dy-y0)*dyinv
+ zz1 = (z - float(kp1)*dz-z0)*dzinv
+
+ xx0=xx1+1
+ yy0=yy1+1
+ zz0=zz1+1
+
+ xx2=1-xx1
+ yy2=1-yy1
+ zz2=1-zz1
+
+ xx3=2-xx1
+ yy3=2-yy1
+ zz3=2-zz1
+
+
+!
+! on repositionne les points de grille par periodicite
+! entre 0 et m-1, puis on numerote de 1 a m
+!
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+
+! print*,ip0,ip1,ip2,ip3
+
+ jp1=mod(jp1+ny,ny) +1
+ jp0=mod(jp0+ny,ny) +1
+ jp2=mod(jp2+ny,ny) +1
+ jp3=mod(jp3+ny,ny) +1
+
+ kp1=mod(kp1+nz,nz) +1
+ kp0=mod(kp0+nz,nz) +1
+ kp2=mod(kp2+nz,nz) +1
+ kp3=mod(kp3+nz,nz) +1
+
+!
+! The M'4 scheme
+!
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp0)*a0*b0*c0
+ g1(i)= g1(i) + GG1(ip0,jp1,kp0)*a0*b1*c0
+ g1(i)= g1(i) + GG1(ip0,jp2,kp0)*a0*b2*c0
+ g1(i)= g1(i) + GG1(ip0,jp3,kp0)*a0*b3*c0
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp0)*a0*b0*c0
+ g2(i)= g2(i) + GG2(ip0,jp1,kp0)*a0*b1*c0
+ g2(i)= g2(i) + GG2(ip0,jp2,kp0)*a0*b2*c0
+ g2(i)= g2(i) + GG2(ip0,jp3,kp0)*a0*b3*c0
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp0)*a0*b0*c0
+ g3(i)= g3(i) + GG3(ip0,jp1,kp0)*a0*b1*c0
+ g3(i)= g3(i) + GG3(ip0,jp2,kp0)*a0*b2*c0
+ g3(i)= g3(i) + GG3(ip0,jp3,kp0)*a0*b3*c0
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp0)*a1*b0*c0
+ g1(i)= g1(i) + GG1(ip1,jp1,kp0)*a1*b1*c0
+ g1(i)= g1(i) + GG1(ip1,jp2,kp0)*a1*b2*c0
+ g1(i)= g1(i) + GG1(ip1,jp3,kp0)*a1*b3*c0
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp0)*a1*b0*c0
+ g2(i)= g2(i) + GG2(ip1,jp1,kp0)*a1*b1*c0
+ g2(i)= g2(i) + GG2(ip1,jp2,kp0)*a1*b2*c0
+ g2(i)= g2(i) + GG2(ip1,jp3,kp0)*a1*b3*c0
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp0)*a1*b0*c0
+ g3(i)= g3(i) + GG3(ip1,jp1,kp0)*a1*b1*c0
+ g3(i)= g3(i) + GG3(ip1,jp2,kp0)*a1*b2*c0
+ g3(i)= g3(i) + GG3(ip1,jp3,kp0)*a1*b3*c0
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp0)*a2*b0*c0
+ g1(i)= g1(i) + GG1(ip2,jp1,kp0)*a2*b1*c0
+ g1(i)= g1(i) + GG1(ip2,jp2,kp0)*a2*b2*c0
+ g1(i)= g1(i) + GG1(ip2,jp3,kp0)*a2*b3*c0
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp0)*a2*b0*c0
+ g2(i)= g2(i) + GG2(ip2,jp1,kp0)*a2*b1*c0
+ g2(i)= g2(i) + GG2(ip2,jp2,kp0)*a2*b2*c0
+ g2(i)= g2(i) + GG2(ip2,jp3,kp0)*a2*b3*c0
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp0)*a2*b0*c0
+ g3(i)= g3(i) + GG3(ip2,jp1,kp0)*a2*b1*c0
+ g3(i)= g3(i) + GG3(ip2,jp2,kp0)*a2*b2*c0
+ g3(i)= g3(i) + GG3(ip2,jp3,kp0)*a2*b3*c0
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp0)*a3*b0*c0
+ g1(i)= g1(i) + GG1(ip3,jp1,kp0)*a3*b1*c0
+ g1(i)= g1(i) + GG1(ip3,jp2,kp0)*a3*b2*c0
+ g1(i)= g1(i) + GG1(ip3,jp3,kp0)*a3*b3*c0
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp0)*a3*b0*c0
+ g2(i)= g2(i) + GG2(ip3,jp1,kp0)*a3*b1*c0
+ g2(i)= g2(i) + GG2(ip3,jp2,kp0)*a3*b2*c0
+ g2(i)= g2(i) + GG2(ip3,jp3,kp0)*a3*b3*c0
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp0)*a3*b0*c0
+ g3(i)= g3(i) + GG3(ip3,jp1,kp0)*a3*b1*c0
+ g3(i)= g3(i) + GG3(ip3,jp2,kp0)*a3*b2*c0
+ g3(i)= g3(i) + GG3(ip3,jp3,kp0)*a3*b3*c0
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp1)*a0*b0*c1
+ g1(i)= g1(i) + GG1(ip0,jp1,kp1)*a0*b1*c1
+ g1(i)= g1(i) + GG1(ip0,jp2,kp1)*a0*b2*c1
+ g1(i)= g1(i) + GG1(ip0,jp3,kp1)*a0*b3*c1
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp1)*a0*b0*c1
+ g2(i)= g2(i) + GG2(ip0,jp1,kp1)*a0*b1*c1
+ g2(i)= g2(i) + GG2(ip0,jp2,kp1)*a0*b2*c1
+ g2(i)= g2(i) + GG2(ip0,jp3,kp1)*a0*b3*c1
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp1)*a0*b0*c1
+ g3(i)= g3(i) + GG3(ip0,jp1,kp1)*a0*b1*c1
+ g3(i)= g3(i) + GG3(ip0,jp2,kp1)*a0*b2*c1
+ g3(i)= g3(i) + GG3(ip0,jp3,kp1)*a0*b3*c1
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp1)*a1*b0*c1
+ g1(i)= g1(i) + GG1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + GG1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + GG1(ip1,jp3,kp1)*a1*b3*c1
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp1)*a1*b0*c1
+ g2(i)= g2(i) + GG2(ip1,jp1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + GG2(ip1,jp2,kp1)*a1*b2*c1
+ g2(i)= g2(i) + GG2(ip1,jp3,kp1)*a1*b3*c1
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp1)*a1*b0*c1
+ g3(i)= g3(i) + GG3(ip1,jp1,kp1)*a1*b1*c1
+ g3(i)= g3(i) + GG3(ip1,jp2,kp1)*a1*b2*c1
+ g3(i)= g3(i) + GG3(ip1,jp3,kp1)*a1*b3*c1
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp1)*a2*b0*c1
+ g1(i)= g1(i) + GG1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + GG1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + GG1(ip2,jp3,kp1)*a2*b3*c1
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp1)*a2*b0*c1
+ g2(i)= g2(i) + GG2(ip2,jp1,kp1)*a2*b1*c1
+ g2(i)= g2(i) + GG2(ip2,jp2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + GG2(ip2,jp3,kp1)*a2*b3*c1
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp1)*a2*b0*c1
+ g3(i)= g3(i) + GG3(ip2,jp1,kp1)*a2*b1*c1
+ g3(i)= g3(i) + GG3(ip2,jp2,kp1)*a2*b2*c1
+ g3(i)= g3(i) + GG3(ip2,jp3,kp1)*a2*b3*c1
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp1)*a3*b0*c1
+ g1(i)= g1(i) + GG1(ip3,jp1,kp1)*a3*b1*c1
+ g1(i)= g1(i) + GG1(ip3,jp2,kp1)*a3*b2*c1
+ g1(i)= g1(i) + GG1(ip3,jp3,kp1)*a3*b3*c1
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp1)*a3*b0*c1
+ g2(i)= g2(i) + GG2(ip3,jp1,kp1)*a3*b1*c1
+ g2(i)= g2(i) + GG2(ip3,jp2,kp1)*a3*b2*c1
+ g2(i)= g2(i) + GG2(ip3,jp3,kp1)*a3*b3*c1
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp1)*a3*b0*c1
+ g3(i)= g3(i) + GG3(ip3,jp1,kp1)*a3*b1*c1
+ g3(i)= g3(i) + GG3(ip3,jp2,kp1)*a3*b2*c1
+ g3(i)= g3(i) + GG3(ip3,jp3,kp1)*a3*b3*c1
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp2)*a0*b0*c2
+ g1(i)= g1(i) + GG1(ip0,jp1,kp2)*a0*b1*c2
+ g1(i)= g1(i) + GG1(ip0,jp2,kp2)*a0*b2*c2
+ g1(i)= g1(i) + GG1(ip0,jp3,kp2)*a0*b3*c2
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp2)*a0*b0*c2
+ g2(i)= g2(i) + GG2(ip0,jp1,kp2)*a0*b1*c2
+ g2(i)= g2(i) + GG2(ip0,jp2,kp2)*a0*b2*c2
+ g2(i)= g2(i) + GG2(ip0,jp3,kp2)*a0*b3*c2
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp2)*a0*b0*c2
+ g3(i)= g3(i) + GG3(ip0,jp1,kp2)*a0*b1*c2
+ g3(i)= g3(i) + GG3(ip0,jp2,kp2)*a0*b2*c2
+ g3(i)= g3(i) + GG3(ip0,jp3,kp2)*a0*b3*c2
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp2)*a1*b0*c2
+ g1(i)= g1(i) + GG1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + GG1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + GG1(ip1,jp3,kp2)*a1*b3*c2
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp2)*a1*b0*c2
+ g2(i)= g2(i) + GG2(ip1,jp1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + GG2(ip1,jp2,kp2)*a1*b2*c2
+ g2(i)= g2(i) + GG2(ip1,jp3,kp2)*a1*b3*c2
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp2)*a1*b0*c2
+ g3(i)= g3(i) + GG3(ip1,jp1,kp2)*a1*b1*c2
+ g3(i)= g3(i) + GG3(ip1,jp2,kp2)*a1*b2*c2
+ g3(i)= g3(i) + GG3(ip1,jp3,kp2)*a1*b3*c2
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp2)*a2*b0*c2
+ g1(i)= g1(i) + GG1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + GG1(ip2,jp2,kp2)*a2*b2*c2
+ g1(i)= g1(i) + GG1(ip2,jp3,kp2)*a2*b3*c2
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp2)*a2*b0*c2
+ g2(i)= g2(i) + GG2(ip2,jp1,kp2)*a2*b1*c2
+ g2(i)= g2(i) + GG2(ip2,jp2,kp2)*a2*b2*c2
+ g2(i)= g2(i) + GG2(ip2,jp3,kp2)*a2*b3*c2
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp2)*a2*b0*c2
+ g3(i)= g3(i) + GG3(ip2,jp1,kp2)*a2*b1*c2
+ g3(i)= g3(i) + GG3(ip2,jp2,kp2)*a2*b2*c2
+ g3(i)= g3(i) + GG3(ip2,jp3,kp2)*a2*b3*c2
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp2)*a3*b0*c2
+ g1(i)= g1(i) + GG1(ip3,jp1,kp2)*a3*b1*c2
+ g1(i)= g1(i) + GG1(ip3,jp2,kp2)*a3*b2*c2
+ g1(i)= g1(i) + GG1(ip3,jp3,kp2)*a3*b3*c2
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp2)*a3*b0*c2
+ g2(i)= g2(i) + GG2(ip3,jp1,kp2)*a3*b1*c2
+ g2(i)= g2(i) + GG2(ip3,jp2,kp2)*a3*b2*c2
+ g2(i)= g2(i) + GG2(ip3,jp3,kp2)*a3*b3*c2
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp2)*a3*b0*c2
+ g3(i)= g3(i) + GG3(ip3,jp1,kp2)*a3*b1*c2
+ g3(i)= g3(i) + GG3(ip3,jp2,kp2)*a3*b2*c2
+ g3(i)= g3(i) + GG3(ip3,jp3,kp2)*a3*b3*c2
+
+ g1(i)= g1(i) + GG1(ip0,jp0,kp3)*a0*b0*c3
+ g1(i)= g1(i) + GG1(ip0,jp1,kp3)*a0*b1*c3
+ g1(i)= g1(i) + GG1(ip0,jp2,kp3)*a0*b2*c3
+ g1(i)= g1(i) + GG1(ip0,jp3,kp3)*a0*b3*c3
+
+ g2(i)= g2(i) + GG2(ip0,jp0,kp3)*a0*b0*c3
+ g2(i)= g2(i) + GG2(ip0,jp1,kp3)*a0*b1*c3
+ g2(i)= g2(i) + GG2(ip0,jp2,kp3)*a0*b2*c3
+ g2(i)= g2(i) + GG2(ip0,jp3,kp3)*a0*b3*c3
+
+ g3(i)= g3(i) + GG3(ip0,jp0,kp3)*a0*b0*c3
+ g3(i)= g3(i) + GG3(ip0,jp1,kp3)*a0*b1*c3
+ g3(i)= g3(i) + GG3(ip0,jp2,kp3)*a0*b2*c3
+ g3(i)= g3(i) + GG3(ip0,jp3,kp3)*a0*b3*c3
+
+ g1(i)= g1(i) + GG1(ip1,jp0,kp3)*a1*b0*c3
+ g1(i)= g1(i) + GG1(ip1,jp1,kp3)*a1*b1*c3
+ g1(i)= g1(i) + GG1(ip1,jp2,kp3)*a1*b2*c3
+ g1(i)= g1(i) + GG1(ip1,jp3,kp3)*a1*b3*c3
+
+ g2(i)= g2(i) + GG2(ip1,jp0,kp3)*a1*b0*c3
+ g2(i)= g2(i) + GG2(ip1,jp1,kp3)*a1*b1*c3
+ g2(i)= g2(i) + GG2(ip1,jp2,kp3)*a1*b2*c3
+ g2(i)= g2(i) + GG2(ip1,jp3,kp3)*a1*b3*c3
+
+ g3(i)= g3(i) + GG3(ip1,jp0,kp3)*a1*b0*c3
+ g3(i)= g3(i) + GG3(ip1,jp1,kp3)*a1*b1*c3
+ g3(i)= g3(i) + GG3(ip1,jp2,kp3)*a1*b2*c3
+ g3(i)= g3(i) + GG3(ip1,jp3,kp3)*a1*b3*c3
+
+ g1(i)= g1(i) + GG1(ip2,jp0,kp3)*a2*b0*c3
+ g1(i)= g1(i) + GG1(ip2,jp1,kp3)*a2*b1*c3
+ g1(i)= g1(i) + GG1(ip2,jp2,kp3)*a2*b2*c3
+ g1(i)= g1(i) + GG1(ip2,jp3,kp3)*a2*b3*c3
+
+ g2(i)= g2(i) + GG2(ip2,jp0,kp3)*a2*b0*c3
+ g2(i)= g2(i) + GG2(ip2,jp1,kp3)*a2*b1*c3
+ g2(i)= g2(i) + GG2(ip2,jp2,kp3)*a2*b2*c3
+ g2(i)= g2(i) + GG2(ip2,jp3,kp3)*a2*b3*c3
+
+ g3(i)= g3(i) + GG3(ip2,jp0,kp3)*a2*b0*c3
+ g3(i)= g3(i) + GG3(ip2,jp1,kp3)*a2*b1*c3
+ g3(i)= g3(i) + GG3(ip2,jp2,kp3)*a2*b2*c3
+ g3(i)= g3(i) + GG3(ip2,jp3,kp3)*a2*b3*c3
+
+ g1(i)= g1(i) + GG1(ip3,jp0,kp3)*a3*b0*c3
+ g1(i)= g1(i) + GG1(ip3,jp1,kp3)*a3*b1*c3
+ g1(i)= g1(i) + GG1(ip3,jp2,kp3)*a3*b2*c3
+ g1(i)= g1(i) + GG1(ip3,jp3,kp3)*a3*b3*c3
+
+ g2(i)= g2(i) + GG2(ip3,jp0,kp3)*a3*b0*c3
+ g2(i)= g2(i) + GG2(ip3,jp1,kp3)*a3*b1*c3
+ g2(i)= g2(i) + GG2(ip3,jp2,kp3)*a3*b2*c3
+ g2(i)= g2(i) + GG2(ip3,jp3,kp3)*a3*b3*c3
+
+ g3(i)= g3(i) + GG3(ip3,jp0,kp3)*a3*b0*c3
+ g3(i)= g3(i) + GG3(ip3,jp1,kp3)*a3*b1*c3
+ g3(i)= g3(i) + GG3(ip3,jp2,kp3)*a3*b2*c3
+ g3(i)= g3(i) + GG3(ip3,jp3,kp3)*a3*b3*c3
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/main.f90 b/CodesEnVrac/CodeGH/src-sphere/main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1c2beea85401c4c71c5d4bf3d67cd42d19d7fd9c
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/main.f90
@@ -0,0 +1,300 @@
+program cylindre
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp(npm),yp(npm),zp(npm),dv(npm)
+ dimension omx(npm),omy(npm),omz(npm)
+ dimension vx(npm),vy(npm),vz(npm)
+ dimension strx(npm),stry(npm),strz(npm)
+
+ dimension domx(npm),domy(npm),domz(npm)
+ ! tableuax supplementaries pour RK
+ dimension xp0(npm),yp0(npm),zp0(npm)
+ dimension om1(npm),om2(npm),om3(npm)
+ dimension strxv(4,npm),stryv(4,npm),strzv(4,npm)
+ dimension vxv(4,npm),vyv(4,npm),vzv(4,npm)
+ dimension para(4)
+ dimension enstrophy(0:1000),energy(0:1000),divergence(0:1000)
+
+ data (para(i),i=1,4)/0.5,0.5,1.,0./
+
+ character*30 filevelx,filevely,filevelz
+
+
+ pi=3.1415926
+ pi2=2.*pi
+
+
+
+ OPEN(1,file='C_IN.DAT',status='OLD')
+ READ(1,*)
+ read(1,*) nx
+ READ(1,*)
+ read(1,*)tstop
+ READ(1,*)
+ read(1,*)coef_pen
+ READ(1,*)
+ read(1,*)reynolds
+ READ(1,*)
+ read(1,*)coef_les
+ READ(1,*)
+ read(1,*)tvisu
+ READ(1,*)
+ read(1,*) width
+
+
+ anu=0.5*0.4844/reynolds
+ coef_drag=8./(pi*0.2422*0.2422)
+ nit=50000
+
+ close(1)
+ tvisu=0.3
+ idif=1
+
+ xmin=-0.
+ xmax=1.
+ ymin=0.
+ ymax=1.
+ zmin=xmin
+ zmax=xmax
+
+ ! dialetre de la spher selon Folke
+ diam=(xmax-xmin)*0.2422
+
+ ny=nx
+ nz=nx
+ dx=(xmax-xmin)/(nx)
+ dy=(ymax-ymin)/(ny)
+ dz=(zmax-zmin)/(nz)
+
+ delt=0.01
+
+
+ call init(npart,xp,yp,zp,omx,omy,omz,dv)
+ time=0.
+ go to 222
+ call reinit(npart,xp,yp,zp,omx,omy,omz,dv)
+ time=10.
+ call velox_fft
+ call vfix
+ call stretch
+222 continue
+
+ OPEN(35,file='DRAGd',status='unknown')
+
+ ! debut des iterations
+
+ tcompt=0.
+ istep=0
+
+ do 20 kk=1,nit
+
+ if (kk.gt.1) delt=amin1(0.01,0.25/omax2)
+ time=time+delt
+
+ j1=16
+ if (nx.eq.256) j1=32
+ j2=nx-j1
+ call drag(drag1,drag2,drag3,j1,j2)
+ call drag_surface(drag4,anu,j1,j2)
+ if (kk.gt.1) then
+ drag_dudt=(drag1-drag1_0)/delt
+ drag_dwdt=0.5*coef_drag*(drag2-drag2_0)/delt
+ print*,'DRAGdwdt ',drag_dwdt
+ drag_dwdt=drag_dwdt+0.5*coef_drag*drag4
+ drag_poreux=2.*coef_pen*drag3/diam
+ endif
+ print*,' time, DRAGs ',kk,time,drag_dwdt,drag_poreux
+ write(35,*) time,drag_dwdt
+ drag2_0=drag2
+
+ deltconv=delt
+ delt1=delt/6.
+
+ ! on fait les sous-iterations R.K.
+
+ do 10 i=1,npart
+ xp0(i)=xp(i)
+ yp0(i)=yp(i)
+ zp0(i)=zp(i)
+ om1(i)=omx(i)
+ om2(i)=omy(i)
+ om3(i)=omz(i)
+10 continue
+
+ do 550 ll=1,4
+
+ call intervm4(npart,vx,vy,vz,xp,yp,zp)
+ call intersm4(npart,strx,stry,strz,xp,yp,zp)
+
+ ! increment des positions et poids correspondant aux sous-ite
+ ! RK
+ !**********************
+
+ vxmax=0.
+ vxmax=-10000.
+ vxmin=10000.
+ vymax=-10000.
+ vymin=10000.
+ vzmax=-10000.
+ vzmin=10000.
+ vzmax=0.
+ do 520 i=1,npart
+ vxv(ll,i)=vx(i)
+ vyv(ll,i)=vy(i)
+ vzv(ll,i)=vz(i)
+ strxv(ll,i)=dv(i)*strx(i)
+ stryv(ll,i)=dv(i)*stry(i)
+ strzv(ll,i)=dv(i)*strz(i)
+ xp(i)=xp0(i)+para(ll)*deltconv*vx(i)
+ if (xp(i).lt.xmin) xp(i)=xp(i)+xmax-xmin
+ if (xp(i).gt.xmax) xp(i)=xp(i)-xmax+xmin
+ yp(i)=yp0(i)+para(ll)*deltconv*vy(i)
+ if (yp(i).lt.ymin) yp(i)=yp(i)+ymax-ymin
+ if (yp(i).gt.ymax) yp(i)=yp(i)-ymax+ymin
+ zp(i)=zp0(i)+para(ll)*deltconv*vz(i)
+ if (zp(i).lt.zmin) zp(i)=zp(i)+zmax-zmin
+ if (zp(i).gt.zmax) zp(i)=zp(i)-zmax+zmin
+ omx(i)=om1(i)+para(ll)*deltconv*dv(i)*strx(i)
+ omy(i)=om2(i)+para(ll)*deltconv*dv(i)*stry(i)
+ omz(i)=om3(i)+para(ll)*deltconv*dv(i)*strz(i)
+ vxmax=amax1(vxmax,(vx(i)))
+ vxmin=amin1(vxmin,(vx(i)))
+ vymax=amax1(vymax,(vy(i)))
+ vymin=amin1(vymin,(vy(i)))
+ vzmax=amax1(vzmax,(vz(i)))
+ vzmin=amin1(vzmin,(vz(i)))
+520 continue
+ ! print*,' vitesses max ',vxmax,vxmin,vymax,vymin,vzmax,vzmin
+
+550 continue
+
+ ! FIN des sous-ite RK
+ !**********************
+
+ ! Increments des positions et poids pour
+ ! la partie transport-deformation du tourbillon
+
+
+ xleft=xmax
+ xright=xmin
+ yleft=ymax
+ yright=ymin
+ zleft=zmax
+ zright=zmin
+ do 900 i=1,npart
+ xp(i)=xp0(i)+delt1*(vxv(1,i)+2.*vxv(2,i)+2.*vxv(3,i)+vxv(4,i))
+ yp(i)=yp0(i)+delt1*(vyv(1,i)+2.*vyv(2,i)+2.*vyv(3,i)+vyv(4,i))
+ zp(i)=zp0(i)+delt1*(vzv(1,i)+2.*vzv(2,i)+2.*vzv(3,i)+vzv(4,i))
+ if (xp(i).lt.xmin) xp(i)=xp(i)+xmax-xmin
+ if (xp(i).gt.xmax) xp(i)=xp(i)-xmax+xmin
+ if (yp(i).lt.ymin) yp(i)=yp(i)+ymax-ymin
+ if (yp(i).gt.ymax) yp(i)=yp(i)-ymax+ymin
+ if (zp(i).lt.zmin) zp(i)=zp(i)+zmax-zmin
+ if (zp(i).gt.zmax) zp(i)=zp(i)-zmax+zmin
+ omx(i)=om1(i)+delt1*(strxv(1,i)+2.*strxv(2,i)+&
+ 2.*strxv(3,i)+strxv(4,i))
+ omy(i)=om2(i)+delt1*(stryv(1,i)+2.*stryv(2,i)+&
+ 2.*stryv(3,i)+stryv(4,i))
+ omz(i)=om3(i)+delt1*(strzv(1,i)+2.*strzv(2,i)+&
+ 2.*strzv(3,i)+strzv(4,i))
+900 continue
+
+
+
+
+ ! Remshing + Diffusion
+ !**********************
+
+ ! circlim=0.0001
+ ! circulation mimimum pour troncature de la vorticite dans remaillage
+ circlim=-10.
+
+ call remesh_om(npart,omx,omy,omz,xp,yp,zp,dv)
+
+ call velox_fft
+ call vfix
+
+ if (time.ge.tstop) then
+ OPEN(33,file='SPEEDz',status='unknown')
+ OPEN(34,file='SPEEDy',status='unknown')
+ do k=1,nx
+ write(33,*) (k-1)*dx,vxg(nx/2,nx/2,k),vxg(1,k,1)
+ write(34,*) (k-1)*dx,vxg(nx/2,k,nx/2),vxg(1,k,nx/2),vxg(1,k,1)
+ enddo
+ endif
+
+
+ ! call pen(coef_pen,delt)
+ call pen_diff_fft(coef_pen,npart,anu,delt,xp,yp,zp,omx,omy,omz,dv,omax2)
+
+ call stretch
+
+ ! call dif_om(npart,omx,omy,omz,
+ ! 1 xp,yp,zp,dv,anu,delt,omax2)
+
+ ! call diff_fft(npart,anu,delt,
+ ! 1 xp,yp,zp,omx,omy,omz,dv,omax2)
+
+ print *,' Npart ',npart
+
+
+ if (time.ge.tstop) then
+
+ ! OPEN(33,file='SPEEDz',status='unknown')
+ ! OPEN(34,file='SPEEDy',status='unknown')
+ ! do k=1,nx
+ ! write(33,*) (k-1)*dx,vxg(nx/2,nx/2,k),vxg(1,k,1)
+ ! write(34,*) (k-1)*dx,vxg(nx/2,k,nx/2),vxg(1,k,nx/2),
+ ! 1 vxg(1,k,1)
+ ! enddo
+ open(24,file='fileom')
+ umax=0.
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx," ",nx," ",nx
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dx," ",dx
+ WRITE(24,*) "POINT_DATA ",nx*nx*nx
+ WRITE(24,'(A)') "SCALARS omg float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nx
+ do j=1,nx
+ do i=1,nx
+ strength=sqrt(omg1(i,j,k)**2+omg2(i,j,k)**2+omg3(i,j,k)**2)
+ ! strength=sqrt(vxg(i,j,k)**2+vyg(i,j,k)**2+vzg(i,j,k)**2)
+ ! umax=amax1(umax,abs(ug(i,j,k)))
+ write(24,*) amax1(0.00001,strength)
+ enddo
+ enddo
+ enddo
+ close(24)
+ close(33)
+ close(34)
+ ! goto 201
+ ! endif
+
+ open(2,file='fileomx',form='unformatted',convert='big_endian',status='unknown')
+ open(3,file='fileomy',form='unformatted',convert='big_endian',status='unknown')
+ open(4,file='fileomz',form='unformatted',convert='big_endian',status='unknown')
+
+ write(2) ((((omg1(i,j,k)),i=1,nx),j=1,ny),k=1,nz)
+ write(3) ((((omg2(i,j,k)),i=1,nx),j=1,ny),k=1,nz)
+ write(4) (((omg3(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ close(2)
+ close(3)
+ close(4)
+ goto 201
+
+ endif
+
+20 continue
+
+201 continue
+ stop
+
+end program cylindre
diff --git a/CodesEnVrac/CodeGH/src-sphere/param.h b/CodesEnVrac/CodeGH/src-sphere/param.h
new file mode 100644
index 0000000000000000000000000000000000000000..edb596f8ff311293c6660c3a4996a37459d965cc
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/param.h
@@ -0,0 +1,5 @@
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx,ny,nz,nt,dx,dy,dz,ifft
+ common width
+ common vzh,zg
+
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/pen.f90 b/CodesEnVrac/CodeGH/src-sphere/pen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0a889d0c3a6404f82b9a2872f2079c152b57e4d8
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/pen.f90
@@ -0,0 +1,69 @@
+ subroutine pen(coef_pen,delt)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+!condition limite v=vh par penalisation implicite en vorticite
+
+ cdelt=coef_pen*delt
+
+ vxh=0.
+ vyh=0.
+ vzh=0.
+
+!penalisation sous forme :
+!omega_n+1=curl[(u_n+coef_pen*delt*vh)/(1+coef_pen)]
+
+ do k=1,nz
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ do i=1,nx
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ arg=phig(i,j,k)
+ argt=phig(i,jt,k)
+ argb=phig(i,jb,k)
+ argu=phig(i,j,kt)
+ argd=phig(i,j,kb)
+ argr=phig(it,j,k)
+ argl=phig(ib,j,k)
+
+!x-component:
+ term1=(vzg(i,jt,k)+argt*cdelt*vzh)/(1.+cdelt*argt)
+ term2=(vzg(i,jb,k)+argb*cdelt*vzh)/(1.+cdelt*argb)
+ omg1(i,j,k)=(term1-term2)/(2.*dx)
+ term1=(vyg(i,j,kt)+argu*cdelt*vyh)/(1.+cdelt*argu)
+ term2=(vyg(i,j,kb)+argd*cdelt*vyh)/(1.+cdelt*argd)
+ omg1(i,j,k)=omg1(i,j,k)-(term1-term2)/(2.*dx)
+
+!y-component:
+ term1=(vxg(i,j,kt)+argu*cdelt*vxh)/(1.+cdelt*argu)
+ term2=(vxg(i,j,kb)+argd*cdelt*vxh)/(1.+cdelt*argd)
+ omg2(i,j,k)=(term1-term2)/(2.*dx)
+ term1=(vzg(it,j,k)+argr*cdelt*vzh)/(1.+cdelt*argr)
+ term2=(vzg(ib,j,k)+argl*cdelt*vzh)/(1.+cdelt*argl)
+ omg2(i,j,k)=omg2(i,j,k)-(term1-term2)/(2.*dx)
+
+!z-component:
+ term1=(vyg(it,j,k)+argu*cdelt*vyh)/(1.+cdelt*argr)
+ term2=(vyg(ib,j,k)+argd*cdelt*vyh)/(1.+cdelt*argl)
+ omg3(i,j,k)=(term1-term2)/(2.*dx)
+ term1=(vxg(i,jt,k)+argr*cdelt*vxh)/(1.+cdelt*argt)
+ term2=(vxg(i,jb,k)+argl*cdelt*vxh)/(1.+cdelt*argb)
+ omg3(i,j,k)=omg3(i,j,k)-(term1-term2)/(2.*dx)
+
+111 continue
+ enddo
+ enddo
+ enddo
+
+
+
+
+ return
+ end
diff --git a/CodesEnVrac/CodeGH/src-sphere/pen_dif_fft.f90 b/CodesEnVrac/CodeGH/src-sphere/pen_dif_fft.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a84b2da1dfee2feccafb6e52fcc77d81bd3b6863
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/pen_dif_fft.f90
@@ -0,0 +1,138 @@
+subroutine pen_diff_fft(coef_pen,npart,anu,delt,xp1,yp1,zp1,om1,om2,om3,dv1,omax2)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ !condition limite v=vh par penalisation implicite en vorticite
+ !penalisation sur v, puis fft, puis om en fourier
+ !puis diff implicite en fourier, puis retour omg
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+
+ dimension aux3(npg,npg,npg),aux1(npg,npg,npg),aux2(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,cox,coy,coz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cox(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ wk(ngx2+1,npgy,npgz)
+
+ pi=3.1415926
+ dxinv=0.5/dx
+ dyinv=dxinv
+ dzinv=dxinv
+
+ ! calucl de fonction courants 3d
+
+ nx2=nx/2
+ ny2=ny/2
+ nz2=nz/2
+
+ cdelt=coef_pen*delt
+
+ vxh=0.
+ vyh=0.
+ vzh=0.
+
+ !penalisation sous forme :
+ !u_n+1=[(u_n+coef_pen*delt*vh*phi)/(1+coef_pen*delt*phi)]
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ arg=phig(i,j,k)
+
+ !x-component:
+ vxg(i,j,k)=(vxg(i,j,k)+arg*cdelt*vxh)/(1.+cdelt*arg)
+ vyg(i,j,k)=(vyg(i,j,k)+arg*cdelt*vyh)/(1.+cdelt*arg)
+ vzg(i,j,k)=(vzg(i,j,k)+arg*cdelt*vzh)/(1.+cdelt*arg)
+ enddo
+ enddo
+ enddo
+
+ call fftw3d(vxg,cfx,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(vyg,cfy,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(vzg,cfz,nx,ny,nz,nx2,ny2,nz2,wk,0)
+
+ ! calcul rotationnel et difusion implicite
+ ! sur omega
+
+ anudt=anu*delt
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do k=1-nz2,nz2
+ rk=float(k)*ak
+ do j=1-ny2,ny2
+ rj=float(j)*aj
+ do i=0,nx2
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ r2b=(1.+r2*anudt)
+ ! diffusion en fourier
+ cox(i,j,k)=cmplx(0.0,1.0)*(+rj*cfz(i,j,k)-rk*cfy(i,j,k))/r2b
+ coy(i,j,k)=cmplx(0.0,1.0)*(+rk*cfx(i,j,k)-ri*cfz(i,j,k))/r2b
+ coz(i,j,k)=cmplx(0.0,1.0)*(+ri*cfy(i,j,k)-rj*cfx(i,j,k))/r2b
+ end do
+ end do
+ end do
+
+
+ ! fourier inverse pour vorticite apres difusion
+ ! et creation de particules
+
+ call fftw3d(aux1,cox,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,coy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,coz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+ circlim=0.0001
+ npart=0
+ vol=dx**3
+ omax1=0.
+ omax2=0.
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ omg1(i,j,k)=aux1(i,j,k)
+ omg2(i,j,k)=aux2(i,j,k)
+ omg3(i,j,k)=aux3(i,j,k)
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ x=xmin+float(i-1)*dx
+ y=xmin+float(j-1)*dx
+ z=xmin+float(k-1)*dx
+ npart=npart+1
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ omax2=amax1(omax2,abs(omg1(i,j,k)))
+ omax2=amax1(omax2,abs(omg2(i,j,k)))
+ omax2=amax1(omax2,abs(omg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'OMAX avant et apres DIFF ',omax1,omax2
+
+ return
+
+end subroutine pen_diff_fft
diff --git a/CodesEnVrac/CodeGH/src-sphere/reinit.f90 b/CodesEnVrac/CodeGH/src-sphere/reinit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6f754269775af64c5dcedd66f3c61bb4e4219d56
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/reinit.f90
@@ -0,0 +1,68 @@
+subroutine reinit(npart,xp,yp,zp,omx,omy,omz,dv)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp(*),yp(*),zp(*),dv(*)
+ dimension omx(*),omy(*),omz(*)
+
+ character*30 rota
+
+ pi=3.1415926
+ piinv = 1./( pi)
+ pi2=2.*pi
+
+ xc=(xmin+xmax)/2.
+ yc=xc
+ zc=xc
+ ! rc1=0.1
+ rc1=(xmax-xmin)*0.1211
+
+ open(2,file='fileomx',form='unformatted',convert='big_endian',status='unknown')
+ open(3,file='fileomy',form='unformatted',convert='big_endian',status='unknown')
+ open(4,file='fileomz',form='unformatted',convert='big_endian',status='unknown')
+
+ read(2,*) (((omg1(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ read(3,*) (((omg2(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ read(4,*) (((omg3(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+ close(2)
+ close(3)
+ close(4)
+
+ eps=dx*width
+ vol=dx**3
+ circlim=0.0001
+
+ npart=0.
+ do i=1,nx
+ xx=xmin+(float(i)-1.)*dx
+ DO j=1,ny
+ yy=ymin+(float(j)-1.)*dy
+ DO k=1,nz
+ zz=zmin+(float(k)-1.)*dz
+ r1 =sqrt((xx-xc)**2+(yy-yc)**2+(zz-zc)**2)-rc1
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ npart=npart+1
+ xp(npart)=xx
+ yp(npart)=yy
+ zp(npart)=zz
+ dv(npart)=dx**3
+ omx(npart)=omg1(i,j,k)*vol
+ omy(npart)=omg2(i,j,k)*vol
+ omz(npart)=omg3(i,j,k)*vol
+ endif
+ phig(i,j,k)=amin1(1.,amax1(1.-r1/eps,0.))
+ if ((j.le.4).or.(j.ge.nx-3)) phig(i,j,k)=1.
+ end DO
+ end DO
+ end do
+ print*, 'NPART =', npart
+ return
+end subroutine reinit
+
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/remesh.f90 b/CodesEnVrac/CodeGH/src-sphere/remesh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2bbed6937e7f2b69b0936cfd748eb491ba9c6d23
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/remesh.f90
@@ -0,0 +1,579 @@
+ SUBROUTINE remeshdif(npart,circlim,om1,om2,om3,xp,yp,zp,dv,anu,delt)
+
+! This subroutine asssigns vorticity on a grid
+!----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension om1(*),om2(*),om3(*),xp(*),yp(*),zp(*),dv(*)
+ dimension dom1(npm),dom2(npm),dom3(npm)
+ integer indx(npm),indy(npm),indz(npm)
+
+
+
+ pi=3.1415926
+
+ do 10 k=1,nz
+ do 10 j=1,ny
+ do 10 i=1,nx
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+10 continue
+
+ dxinv=1./dx
+ dyinv=1./dy
+ dzinv=1./dz
+
+
+
+!--------------------------------------------------------------------
+!- PART II : Determination of the circulation of each particle
+!--------------------------------------------------------------------
+
+!x0=xmin-.5*dx
+!y0=ymin-.5*dy
+!z0=zmin-.5*dz
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ xm=xmax-xmin
+ ym=ymax-ymin
+ zm=zmax-zmin
+
+ DO 20 n = 1,npart
+
+ g1 = om1(n)
+ g2 = om2(n)
+ g3 = om3(n)
+ x = xp(n)
+ y = yp(n)
+ z = zp(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+!Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ yy1 = (y - float(jp1)*dy-y0)*dyinv
+ zz1 = (z - float(kp1)*dz-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+! on repositionne les points de grille par periodicite
+!entre 0 et npx-1, puis on numerote de 1 a npx
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+ ip3=mod(ip3+nx,nx) +1
+
+ jp1=mod(jp1+ny,ny) +1
+ jp0=mod(jp0+ny,ny) +1
+ jp2=mod(jp2+ny,ny) +1
+ jp3=mod(jp3+ny,ny) +1
+
+ kp1=mod(kp1+nz,nz) +1
+ kp0=mod(kp0+nz,nz) +1
+ kp2=mod(kp2+nz,nz) +1
+ kp3=mod(kp3+nz,nz) +1
+
+!The M'4 scheme
+
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ coef=a0*b0*c0
+ omg1(ip0,jp0,kp0) = omg1(ip0,jp0,kp0) + g1*coef
+ omg2(ip0,jp0,kp0) = omg2(ip0,jp0,kp0) + g2*coef
+ omg3(ip0,jp0,kp0) = omg3(ip0,jp0,kp0) + g3*coef
+
+ coef=a0*b0*c1
+ omg1(ip0,jp0,kp1) = omg1(ip0,jp0,kp1) + g1*coef
+ omg2(ip0,jp0,kp1) = omg2(ip0,jp0,kp1) + g2*coef
+ omg3(ip0,jp0,kp1) = omg3(ip0,jp0,kp1) + g3*coef
+
+ coef=a0*b0*c2
+ omg1(ip0,jp0,kp2) = omg1(ip0,jp0,kp2) + g1*coef
+ omg2(ip0,jp0,kp2) = omg2(ip0,jp0,kp2) + g2*coef
+ omg3(ip0,jp0,kp2) = omg3(ip0,jp0,kp2) + g3*coef
+
+ coef=a0*b0*c3
+ omg1(ip0,jp0,kp3) = omg1(ip0,jp0,kp3) + g1*coef
+ omg2(ip0,jp0,kp3) = omg2(ip0,jp0,kp3) + g2*coef
+ omg3(ip0,jp0,kp3) = omg3(ip0,jp0,kp3) + g3*coef
+
+
+ coef=a0*b1*c0
+ omg1(ip0,jp1,kp0) = omg1(ip0,jp1,kp0) + g1*coef
+ omg2(ip0,jp1,kp0) = omg2(ip0,jp1,kp0) + g2*coef
+ omg3(ip0,jp1,kp0) = omg3(ip0,jp1,kp0) + g3*coef
+
+ coef=a0*b1*c1
+ omg1(ip0,jp1,kp1) = omg1(ip0,jp1,kp1) + g1*coef
+ omg2(ip0,jp1,kp1) = omg2(ip0,jp1,kp1) + g2*coef
+ omg3(ip0,jp1,kp1) = omg3(ip0,jp1,kp1) + g3*coef
+
+ coef=a0*b1*c2
+ omg1(ip0,jp1,kp2) = omg1(ip0,jp1,kp2) + g1*coef
+ omg2(ip0,jp1,kp2) = omg2(ip0,jp1,kp2) + g2*coef
+ omg3(ip0,jp1,kp2) = omg3(ip0,jp1,kp2) + g3*coef
+
+ coef=a0*b1*c3
+ omg1(ip0,jp1,kp3) = omg1(ip0,jp1,kp3) + g1*coef
+ omg2(ip0,jp1,kp3) = omg2(ip0,jp1,kp3) + g2*coef
+ omg3(ip0,jp1,kp3) = omg3(ip0,jp1,kp3) + g3*coef
+
+ coef=a0*b2*c0
+ omg1(ip0,jp2,kp0) = omg1(ip0,jp2,kp0) + g1*coef
+ omg2(ip0,jp2,kp0) = omg2(ip0,jp2,kp0) + g2*coef
+ omg3(ip0,jp2,kp0) = omg3(ip0,jp2,kp0) + g3*coef
+
+ coef=a0*b2*c1
+ omg1(ip0,jp2,kp1) = omg1(ip0,jp2,kp1) + g1*coef
+ omg2(ip0,jp2,kp1) = omg2(ip0,jp2,kp1) + g2*coef
+ omg3(ip0,jp2,kp1) = omg3(ip0,jp2,kp1) + g3*coef
+
+ coef=a0*b2*c2
+ omg1(ip0,jp2,kp2) = omg1(ip0,jp2,kp2) + g1*coef
+ omg2(ip0,jp2,kp2) = omg2(ip0,jp2,kp2) + g2*coef
+ omg3(ip0,jp2,kp2) = omg3(ip0,jp2,kp2) + g3*coef
+
+ coef=a0*b2*c3
+ omg1(ip0,jp2,kp3) = omg1(ip0,jp2,kp3) + g1*coef
+ omg2(ip0,jp2,kp3) = omg2(ip0,jp2,kp3) + g2*coef
+ omg3(ip0,jp2,kp3) = omg3(ip0,jp2,kp3) + g3*coef
+
+ coef=a0*b3*c0
+ omg1(ip0,jp3,kp0) = omg1(ip0,jp3,kp0) + g1*coef
+ omg2(ip0,jp3,kp0) = omg2(ip0,jp3,kp0) + g2*coef
+ omg3(ip0,jp3,kp0) = omg3(ip0,jp3,kp0) + g3*coef
+
+ coef=a0*b3*c1
+ omg1(ip0,jp3,kp1) = omg1(ip0,jp3,kp1) + g1*coef
+ omg2(ip0,jp3,kp1) = omg2(ip0,jp3,kp1) + g2*coef
+ omg3(ip0,jp3,kp1) = omg3(ip0,jp3,kp1) + g3*coef
+
+ coef=a0*b3*c2
+ omg1(ip0,jp3,kp2) = omg1(ip0,jp3,kp2) + g1*coef
+ omg2(ip0,jp3,kp2) = omg2(ip0,jp3,kp2) + g2*coef
+ omg3(ip0,jp3,kp2) = omg3(ip0,jp3,kp2) + g3*coef
+
+ coef=a0*b3*c3
+ omg1(ip0,jp3,kp3) = omg1(ip0,jp3,kp3) + g1*coef
+ omg2(ip0,jp3,kp3) = omg2(ip0,jp3,kp3) + g2*coef
+ omg3(ip0,jp3,kp3) = omg3(ip0,jp3,kp3) + g3*coef
+
+ coef=a1*b0*c0
+ omg1(ip1,jp0,kp0) = omg1(ip1,jp0,kp0) + g1*coef
+ omg2(ip1,jp0,kp0) = omg2(ip1,jp0,kp0) + g2*coef
+ omg3(ip1,jp0,kp0) = omg3(ip1,jp0,kp0) + g3*coef
+
+ coef=a1*b0*c1
+ omg1(ip1,jp0,kp1) = omg1(ip1,jp0,kp1) + g1*coef
+ omg2(ip1,jp0,kp1) = omg2(ip1,jp0,kp1) + g2*coef
+ omg3(ip1,jp0,kp1) = omg3(ip1,jp0,kp1) + g3*coef
+
+ coef=a1*b0*c2
+ omg1(ip1,jp0,kp2) = omg1(ip1,jp0,kp2) + g1*coef
+ omg2(ip1,jp0,kp2) = omg2(ip1,jp0,kp2) + g2*coef
+ omg3(ip1,jp0,kp2) = omg3(ip1,jp0,kp2) + g3*coef
+
+ coef=a1*b0*c3
+ omg1(ip1,jp0,kp3) = omg1(ip1,jp0,kp3) + g1*coef
+ omg2(ip1,jp0,kp3) = omg2(ip1,jp0,kp3) + g2*coef
+ omg3(ip1,jp0,kp3) = omg3(ip1,jp0,kp3) + g3*coef
+
+ coef=a1*b1*c0
+ omg1(ip1,jp1,kp0) = omg1(ip1,jp1,kp0) + g1*coef
+ omg2(ip1,jp1,kp0) = omg2(ip1,jp1,kp0) + g2*coef
+ omg3(ip1,jp1,kp0) = omg3(ip1,jp1,kp0) + g3*coef
+
+ coef=a1*b1*c1
+ omg1(ip1,jp1,kp1) = omg1(ip1,jp1,kp1) + g1*coef
+ omg2(ip1,jp1,kp1) = omg2(ip1,jp1,kp1) + g2*coef
+ omg3(ip1,jp1,kp1) = omg3(ip1,jp1,kp1) + g3*coef
+
+ coef=a1*b1*c2
+ omg1(ip1,jp1,kp2) = omg1(ip1,jp1,kp2) + g1*coef
+ omg2(ip1,jp1,kp2) = omg2(ip1,jp1,kp2) + g2*coef
+ omg3(ip1,jp1,kp2) = omg3(ip1,jp1,kp2) + g3*coef
+
+ coef=a1*b1*c3
+ omg1(ip1,jp1,kp3) = omg1(ip1,jp1,kp3) + g1*coef
+ omg2(ip1,jp1,kp3) = omg2(ip1,jp1,kp3) + g2*coef
+ omg3(ip1,jp1,kp3) = omg3(ip1,jp1,kp3) + g3*coef
+
+
+ coef=a1*b2*c0
+ omg1(ip1,jp2,kp0) = omg1(ip1,jp2,kp0) + g1*coef
+ omg2(ip1,jp2,kp0) = omg2(ip1,jp2,kp0) + g2*coef
+ omg3(ip1,jp2,kp0) = omg3(ip1,jp2,kp0) + g3*coef
+
+ coef=a1*b2*c1
+ omg1(ip1,jp2,kp1) = omg1(ip1,jp2,kp1) + g1*coef
+ omg2(ip1,jp2,kp1) = omg2(ip1,jp2,kp1) + g2*coef
+ omg3(ip1,jp2,kp1) = omg3(ip1,jp2,kp1) + g3*coef
+
+ coef=a1*b2*c2
+ omg1(ip1,jp2,kp2) = omg1(ip1,jp2,kp2) + g1*coef
+ omg2(ip1,jp2,kp2) = omg2(ip1,jp2,kp2) + g2*coef
+ omg3(ip1,jp2,kp2) = omg3(ip1,jp2,kp2) + g3*coef
+
+ coef=a1*b2*c3
+ omg1(ip1,jp2,kp3) = omg1(ip1,jp2,kp3) + g1*coef
+ omg2(ip1,jp2,kp3) = omg2(ip1,jp2,kp3) + g2*coef
+ omg3(ip1,jp2,kp3) = omg3(ip1,jp2,kp3) + g3*coef
+
+ coef=a1*b3*c0
+ omg1(ip1,jp3,kp0) = omg1(ip1,jp3,kp0) + g1*coef
+ omg2(ip1,jp3,kp0) = omg2(ip1,jp3,kp0) + g2*coef
+ omg3(ip1,jp3,kp0) = omg3(ip1,jp3,kp0) + g3*coef
+
+ coef=a1*b3*c1
+ omg1(ip1,jp3,kp1) = omg1(ip1,jp3,kp1) + g1*coef
+ omg2(ip1,jp3,kp1) = omg2(ip1,jp3,kp1) + g2*coef
+ omg3(ip1,jp3,kp1) = omg3(ip1,jp3,kp1) + g3*coef
+
+ coef=a1*b3*c2
+ omg1(ip1,jp3,kp2) = omg1(ip1,jp3,kp2) + g1*coef
+ omg2(ip1,jp3,kp2) = omg2(ip1,jp3,kp2) + g2*coef
+ omg3(ip1,jp3,kp2) = omg3(ip1,jp3,kp2) + g3*coef
+
+ coef=a1*b3*c3
+ omg1(ip1,jp3,kp3) = omg1(ip1,jp3,kp3) + g1*coef
+ omg2(ip1,jp3,kp3) = omg2(ip1,jp3,kp3) + g2*coef
+ omg3(ip1,jp3,kp3) = omg3(ip1,jp3,kp3) + g3*coef
+
+ coef=a2*b0*c0
+ omg1(ip2,jp0,kp0) = omg1(ip2,jp0,kp0) + g1*coef
+ omg2(ip2,jp0,kp0) = omg2(ip2,jp0,kp0) + g2*coef
+ omg3(ip2,jp0,kp0) = omg3(ip2,jp0,kp0) + g3*coef
+
+ coef=a2*b0*c1
+ omg1(ip2,jp0,kp1) = omg1(ip2,jp0,kp1) + g1*coef
+ omg2(ip2,jp0,kp1) = omg2(ip2,jp0,kp1) + g2*coef
+ omg3(ip2,jp0,kp1) = omg3(ip2,jp0,kp1) + g3*coef
+
+ coef=a2*b0*c2
+ omg1(ip2,jp0,kp2) = omg1(ip2,jp0,kp2) + g1*coef
+ omg2(ip2,jp0,kp2) = omg2(ip2,jp0,kp2) + g2*coef
+ omg3(ip2,jp0,kp2) = omg3(ip2,jp0,kp2) + g3*coef
+
+ coef=a2*b0*c3
+ omg1(ip2,jp0,kp3) = omg1(ip2,jp0,kp3) + g1*coef
+ omg2(ip2,jp0,kp3) = omg2(ip2,jp0,kp3) + g2*coef
+ omg3(ip2,jp0,kp3) = omg3(ip2,jp0,kp3) + g3*coef
+
+ coef=a2*b1*c0
+ omg1(ip2,jp1,kp0) = omg1(ip2,jp1,kp0) + g1*coef
+ omg2(ip2,jp1,kp0) = omg2(ip2,jp1,kp0) + g2*coef
+ omg3(ip2,jp1,kp0) = omg3(ip2,jp1,kp0) + g3*coef
+
+ coef=a2*b1*c1
+ omg1(ip2,jp1,kp1) = omg1(ip2,jp1,kp1) + g1*coef
+ omg2(ip2,jp1,kp1) = omg2(ip2,jp1,kp1) + g2*coef
+ omg3(ip2,jp1,kp1) = omg3(ip2,jp1,kp1) + g3*coef
+
+ coef=a2*b1*c2
+ omg1(ip2,jp1,kp2) = omg1(ip2,jp1,kp2) + g1*coef
+ omg2(ip2,jp1,kp2) = omg2(ip2,jp1,kp2) + g2*coef
+ omg3(ip2,jp1,kp2) = omg3(ip2,jp1,kp2) + g3*coef
+
+ coef=a2*b1*c3
+ omg1(ip2,jp1,kp3) = omg1(ip2,jp1,kp3) + g1*coef
+ omg2(ip2,jp1,kp3) = omg2(ip2,jp1,kp3) + g2*coef
+ omg3(ip2,jp1,kp3) = omg3(ip2,jp1,kp3) + g3*coef
+
+ coef=a2*b2*c0
+ omg1(ip2,jp2,kp0) = omg1(ip2,jp2,kp0) + g1*coef
+ omg2(ip2,jp2,kp0) = omg2(ip2,jp2,kp0) + g2*coef
+ omg3(ip2,jp2,kp0) = omg3(ip2,jp2,kp0) + g3*coef
+
+ coef=a2*b2*c1
+ omg1(ip2,jp2,kp1) = omg1(ip2,jp2,kp1) + g1*coef
+ omg2(ip2,jp2,kp1) = omg2(ip2,jp2,kp1) + g2*coef
+ omg3(ip2,jp2,kp1) = omg3(ip2,jp2,kp1) + g3*coef
+
+ coef=a2*b2*c2
+ omg1(ip2,jp2,kp2) = omg1(ip2,jp2,kp2) + g1*coef
+ omg2(ip2,jp2,kp2) = omg2(ip2,jp2,kp2) + g2*coef
+ omg3(ip2,jp2,kp2) = omg3(ip2,jp2,kp2) + g3*coef
+
+ coef=a2*b2*c3
+ omg1(ip2,jp2,kp3) = omg1(ip2,jp2,kp3) + g1*coef
+ omg2(ip2,jp2,kp3) = omg2(ip2,jp2,kp3) + g2*coef
+ omg3(ip2,jp2,kp3) = omg3(ip2,jp2,kp3) + g3*coef
+
+ coef=a2*b3*c0
+ omg1(ip2,jp3,kp0) = omg1(ip2,jp3,kp0) + g1*coef
+ omg2(ip2,jp3,kp0) = omg2(ip2,jp3,kp0) + g2*coef
+ omg3(ip2,jp3,kp0) = omg3(ip2,jp3,kp0) + g3*coef
+
+ coef=a2*b3*c1
+ omg1(ip2,jp3,kp1) = omg1(ip2,jp3,kp1) + g1*coef
+ omg2(ip2,jp3,kp1) = omg2(ip2,jp3,kp1) + g2*coef
+ omg3(ip2,jp3,kp1) = omg3(ip2,jp3,kp1) + g3*coef
+
+ coef=a2*b3*c2
+ omg1(ip2,jp3,kp2) = omg1(ip2,jp3,kp2) + g1*coef
+ omg2(ip2,jp3,kp2) = omg2(ip2,jp3,kp2) + g2*coef
+ omg3(ip2,jp3,kp2) = omg3(ip2,jp3,kp2) + g3*coef
+
+ coef=a2*b3*c3
+ omg1(ip2,jp3,kp3) = omg1(ip2,jp3,kp3) + g1*coef
+ omg2(ip2,jp3,kp3) = omg2(ip2,jp3,kp3) + g2*coef
+ omg3(ip2,jp3,kp3) = omg3(ip2,jp3,kp3) + g3*coef
+
+ coef=a3*b0*c0
+ omg1(ip3,jp0,kp0) = omg1(ip3,jp0,kp0) + g1*coef
+ omg2(ip3,jp0,kp0) = omg2(ip3,jp0,kp0) + g2*coef
+ omg3(ip3,jp0,kp0) = omg3(ip3,jp0,kp0) + g3*coef
+
+ coef=a3*b0*c1
+ omg1(ip3,jp0,kp1) = omg1(ip3,jp0,kp1) + g1*coef
+ omg2(ip3,jp0,kp1) = omg2(ip3,jp0,kp1) + g2*coef
+ omg3(ip3,jp0,kp1) = omg3(ip3,jp0,kp1) + g3*coef
+
+ coef=a3*b0*c2
+ omg1(ip3,jp0,kp2) = omg1(ip3,jp0,kp2) + g1*coef
+ omg2(ip3,jp0,kp2) = omg2(ip3,jp0,kp2) + g2*coef
+ omg3(ip3,jp0,kp2) = omg3(ip3,jp0,kp2) + g3*coef
+
+ coef=a3*b0*c3
+ omg1(ip3,jp0,kp3) = omg1(ip3,jp0,kp3) + g1*coef
+ omg2(ip3,jp0,kp3) = omg2(ip3,jp0,kp3) + g2*coef
+ omg3(ip3,jp0,kp3) = omg3(ip3,jp0,kp3) + g3*coef
+
+ coef=a3*b1*c0
+ omg1(ip3,jp1,kp0) = omg1(ip3,jp1,kp0) + g1*coef
+ omg2(ip3,jp1,kp0) = omg2(ip3,jp1,kp0) + g2*coef
+ omg3(ip3,jp1,kp0) = omg3(ip3,jp1,kp0) + g3*coef
+
+ coef=a3*b1*c1
+ omg1(ip3,jp1,kp1) = omg1(ip3,jp1,kp1) + g1*coef
+ omg2(ip3,jp1,kp1) = omg2(ip3,jp1,kp1) + g2*coef
+ omg3(ip3,jp1,kp1) = omg3(ip3,jp1,kp1) + g3*coef
+
+ coef=a3*b1*c2
+ omg1(ip3,jp1,kp2) = omg1(ip3,jp1,kp2) + g1*coef
+ omg2(ip3,jp1,kp2) = omg2(ip3,jp1,kp2) + g2*coef
+ omg3(ip3,jp1,kp2) = omg3(ip3,jp1,kp2) + g3*coef
+
+ coef=a3*b1*c3
+ omg1(ip3,jp1,kp3) = omg1(ip3,jp1,kp3) + g1*coef
+ omg2(ip3,jp1,kp3) = omg2(ip3,jp1,kp3) + g2*coef
+ omg3(ip3,jp1,kp3) = omg3(ip3,jp1,kp3) + g3*coef
+
+ coef=a3*b2*c0
+ omg1(ip3,jp2,kp0) = omg1(ip3,jp2,kp0) + g1*coef
+ omg2(ip3,jp2,kp0) = omg2(ip3,jp2,kp0) + g2*coef
+ omg3(ip3,jp2,kp0) = omg3(ip3,jp2,kp0) + g3*coef
+
+ coef=a3*b2*c1
+ omg1(ip3,jp2,kp1) = omg1(ip3,jp2,kp1) + g1*coef
+ omg2(ip3,jp2,kp1) = omg2(ip3,jp2,kp1) + g2*coef
+ omg3(ip3,jp2,kp1) = omg3(ip3,jp2,kp1) + g3*coef
+
+ coef=a3*b2*c2
+ omg1(ip3,jp2,kp2) = omg1(ip3,jp2,kp2) + g1*coef
+ omg2(ip3,jp2,kp2) = omg2(ip3,jp2,kp2) + g2*coef
+ omg3(ip3,jp2,kp2) = omg3(ip3,jp2,kp2) + g3*coef
+
+ coef=a3*b2*c3
+ omg1(ip3,jp2,kp3) = omg1(ip3,jp2,kp3) + g1*coef
+ omg2(ip3,jp2,kp3) = omg2(ip3,jp2,kp3) + g2*coef
+ omg3(ip3,jp2,kp3) = omg3(ip3,jp2,kp3) + g3*coef
+
+ coef=a3*b3*c0
+ omg1(ip3,jp3,kp0) = omg1(ip3,jp3,kp0) + g1*coef
+ omg2(ip3,jp3,kp0) = omg2(ip3,jp3,kp0) + g2*coef
+ omg3(ip3,jp3,kp0) = omg3(ip3,jp3,kp0) + g3*coef
+
+ coef=a3*b3*c1
+ omg1(ip3,jp3,kp1) = omg1(ip3,jp3,kp1) + g1*coef
+ omg2(ip3,jp3,kp1) = omg2(ip3,jp3,kp1) + g2*coef
+ omg3(ip3,jp3,kp1) = omg3(ip3,jp3,kp1) + g3*coef
+
+ coef=a3*b3*c2
+ omg1(ip3,jp3,kp2) = omg1(ip3,jp3,kp2) + g1*coef
+ omg2(ip3,jp3,kp2) = omg2(ip3,jp3,kp2) + g2*coef
+ omg3(ip3,jp3,kp2) = omg3(ip3,jp3,kp2) + g3*coef
+
+ coef=a3*b3*c3
+ omg1(ip3,jp3,kp3) = omg1(ip3,jp3,kp3) + g1*coef
+ omg2(ip3,jp3,kp3) = omg2(ip3,jp3,kp3) + g2*coef
+ omg3(ip3,jp3,kp3) = omg3(ip3,jp3,kp3) + g3*coef
+
+20 CONTINUE
+
+ npart=0
+
+ do k=1,nz
+ z=amod(z0-zmin+(k-1)*dz+zm,zm)+zmin
+ do j=1,ny
+ y=amod(y0-ymin+(j-1)*dy+ym,ym)+ymin
+ do i=1,nx
+ x=amod(x0-xmin+(i-1)*dx+xm,xm)+xmin
+ vol=dx*dy*dz
+ strength=abs(omg1(i,j,k))+abs(omg2(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.ge.circlim*vol)) then
+ npart=npart+1
+ indx(npart)=i
+ indy(npart)=j
+ indz(npart)=k
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ dv(npart)=vol
+ om1(npart)=omg1(i,j,k)
+ om2(npart)=omg2(i,j,k)
+ om3(npart)=omg3(i,j,k)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+! goto 310
+
+
+! dans la foulee on fiat la diffusion dans l'espace
+! mappee avec formules de diffusion anisotropes
+
+! pas de temps de diffusion pour CFL
+
+! coeff aspect ratio pour se mettre dans une grille
+! totalement isotrope et coeff de normalisation
+! pour kernel 1/(1+r**2)
+ dzdx=(dz/dx)**2
+ dzdy=(dz/dy)**2
+ trace=dzdx+dzdy+1.
+
+ alpha=3.333333
+ beta=5.666667
+ alambda=2./(beta-alpha)
+ amu=-2.*alpha/((beta-alpha)*(2.*alpha+beta))
+
+! boucle sur les receveurs
+
+
+ tot=0.
+
+ do i=1,npart
+ dom1(i)=0.
+ dom2(i)=0.
+ dom3(i)=0.
+ tot2=0.
+
+ ii=indx(i)
+ jj=indy(i)
+ kk=indz(i)
+ gammarcv1=om1(i)
+ gammarcv2=om2(i)
+ gammarcv3=om3(i)
+ vxrcv=vxg(ii,jj,kk)
+ vyrcv=vyg(ii,jj,kk)
+ vzrcv=vzg(ii,jj,kk)
+
+! boucle sur les 27 sources
+ do lx=-1,1
+ do ly=-1,1
+ do lz=-1,1
+ i2=mod(ii+lx+nx-1,nx)+1
+ j2=mod(jj+ly+ny-1,ny)+1
+ k2=mod(kk+lz+nz-1,nz)+1
+ gammasrc1=omg1(i2,j2,k2)
+ gammasrc2=omg2(i2,j2,k2)
+ gammasrc3=omg3(i2,j2,k2)
+ vxsrc=vxg(i2,j2,k2)
+ vysrc=vyg(i2,j2,k2)
+ vzsrc=vzg(i2,j2,k2)
+ r=lx**2+ly**2+lz**2
+ am1=alambda*dzdx+amu*trace
+ am2=alambda*dzdy+amu*trace
+ am3=alambda+amu*trace
+ akernel=((lx**2)*am1+(ly**2)*am2+(lz**2)*am3)/(1.+r)
+ factor=akernel/(dz*dz)
+ tot2=tot2+akernel
+ dom1(i)=dom1(i)+(gammasrc1-gammarcv1)*(anu*factor)
+ dom2(i)=dom2(i)+(gammasrc2-gammarcv2)*(anu*factor)
+ dom3(i)=dom3(i)+(gammasrc3-gammarcv3)*(anu*factor)
+
+ enddo
+ enddo
+ enddo
+ tot=amax1(tot,tot2*dy*dx*dz/dv(i))
+
+! enddo pour caluc de dom sur les particules
+ enddo
+
+
+
+ omax0=0.
+ omax1=0.
+
+ do i=1,npart
+ omax0=amax1(omax0,abs(om1(i))/dv(i))
+ omax0=amax1(omax0,abs(om2(i))/dv(i))
+ omax0=amax1(omax0,abs(om3(i))/dv(i))
+ om1(i)=om1(i)+delt*dom1(i)
+ om2(i)=om2(i)+delt*dom2(i)
+ om3(i)=om3(i)+delt*dom3(i)
+ omax1=amax1(omax1,abs(om1(i))/dv(i))
+ omax1=amax1(omax1,abs(om2(i))/dv(i))
+ omax1=amax1(omax1,abs(om3(i))/dv(i))
+ enddo
+
+ print*, 'OMAX avant et apres diff ', omax0,omax1
+ if (omax1.gt.omax0) print*, '****** ATTENTION DIFFUSION'
+
+
+310 continue
+
+ RETURN
+ END
diff --git a/CodesEnVrac/CodeGH/src-sphere/remesh_om.f90 b/CodesEnVrac/CodeGH/src-sphere/remesh_om.f90
new file mode 100644
index 0000000000000000000000000000000000000000..296a55f0955f439bb24e1cacc12f2cf649f6ca31
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/remesh_om.f90
@@ -0,0 +1,470 @@
+!================================================================
+SUBROUTINE remesh_om(npart,om1,om2,om3,xp1,yp1,zp1,dv1)
+ ! This subroutine asssigns vorticity on a grid
+ !----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+
+ nx1=nx
+ ny1=nx
+ nz1=nx
+ dx1=dx
+
+
+ do i=1,nx1
+ do j=1,ny1
+ do k=1,nz1
+ omg1(i,j,k)=0.
+ omg2(i,j,k)=0.
+ omg3(i,j,k)=0.
+ end do
+ end do
+ end do
+
+ dy1=dx1
+ dz1=dx1
+
+ dxinv=1./(dx1)
+ dyinv=dxinv
+ dzinv=dxinv
+
+
+
+ !--------------------------------------------------------------------
+ !- PART II : Determination of the circulation of each particle
+ !--------------------------------------------------------------------
+
+ x0=0.
+ y0=0.
+ z0=0.
+
+ vol=dx1*dx1*dx1
+
+ DO n = 1,npart
+
+ g2 = om1(n)/vol
+ g3 = om2(n)/vol
+ g4 = om3(n)/vol
+
+ x = xp1(n)
+ y = yp1(n)
+ z = zp1(n)
+
+ ip1 = int((x-x0)*dxinv)
+ jp1 = int((y-y0)*dyinv)
+ kp1 = int((z-z0)*dzinv)
+
+ ip0 = ip1 - 1
+ jp0 = jp1 - 1
+ kp0 = kp1 - 1
+
+ ip2 = ip1 + 1
+ jp2 = jp1 + 1
+ kp2 = kp1 + 1
+
+ ip3 = ip1 + 2
+ jp3 = jp1 + 2
+ kp3 = kp1 + 2
+
+ ! Assign the circulations to the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx1-x0)*dxinv
+ yy1 = (y - float(jp1)*dy1-y0)*dyinv
+ zz1 = (z - float(kp1)*dz1-z0)*dzinv
+
+ xx0=xx1+1.
+ yy0=yy1+1.
+ zz0=zz1+1.
+
+ xx2=1.-xx1
+ yy2=1.-yy1
+ zz2=1.-zz1
+
+ xx3=2.-xx1
+ yy3=2.-yy1
+ zz3=2.-zz1
+
+
+ !
+ ! on repositionne les points de grille par periodicite
+ ! entre 0 et npx-1, puis on numerote de 1 a npx
+ !
+
+ ip1=mod(ip1+nx1,nx1) +1
+ ip0=mod(ip0+nx1,nx1) +1
+ ip2=mod(ip2+nx1,nx1) +1
+ ip3=mod(ip3+nx1,nx1) +1
+
+ jp1=mod(jp1+ny1,ny1) +1
+ jp0=mod(jp0+ny1,ny1) +1
+ jp2=mod(jp2+ny1,ny1) +1
+ jp3=mod(jp3+ny1,ny1) +1
+
+ kp1=mod(kp1+nz1,nz1) +1
+ kp0=mod(kp0+nz1,nz1) +1
+ kp2=mod(kp2+nz1,nz1) +1
+ kp3=mod(kp3+nz1,nz1) +1
+
+ ! The M'4 scheme
+ !
+ a0 = .5*((2.-xx0)**2)*(1.-xx0)
+ b0 = .5*((2.-yy0)**2)*(1.-yy0)
+ c0 = .5*((2.-zz0)**2)*(1.-zz0)
+
+ a1 = 1.-2.5*xx1*xx1 + 1.5*xx1*xx1*xx1
+ b1 = 1.-2.5*yy1*yy1 + 1.5*yy1*yy1*yy1
+ c1 = 1.-2.5*zz1*zz1 + 1.5*zz1*zz1*zz1
+
+ a2 = 1.-2.5*xx2*xx2 + 1.5*xx2*xx2*xx2
+ b2 = 1.-2.5*yy2*yy2 + 1.5*yy2*yy2*yy2
+ c2 = 1.-2.5*zz2*zz2 + 1.5*zz2*zz2*zz2
+
+ a3 = .5*((2.-xx3)**2)*(1.-xx3)
+ b3 = .5*((2.-yy3)**2)*(1.-yy3)
+ c3 = .5*((2.-zz3)**2)*(1.-zz3)
+
+ ! b1=1.
+ ! b0=0.
+ ! b2=0.
+ ! b3=0.
+ ! a1=1.
+ ! a0=0.
+ ! a2=0.
+ ! a3=0.
+ ! c1=1.
+ ! c0=0.
+ ! c2=0.
+ ! c3=0.
+
+
+ coef=a0*b0*c0
+ omg1(ip0,jp0,kp0) = omg1(ip0,jp0,kp0) + g2*coef
+ omg2(ip0,jp0,kp0) = omg2(ip0,jp0,kp0) + g3*coef
+ omg3(ip0,jp0,kp0) = omg3(ip0,jp0,kp0) + g4*coef
+
+ coef=a0*b0*c1
+ omg1(ip0,jp0,kp1) = omg1(ip0,jp0,kp1) + g2*coef
+ omg2(ip0,jp0,kp1) = omg2(ip0,jp0,kp1) + g3*coef
+ omg3(ip0,jp0,kp1) = omg3(ip0,jp0,kp1) + g4*coef
+
+ coef=a0*b0*c2
+ omg1(ip0,jp0,kp2) = omg1(ip0,jp0,kp2) + g2*coef
+ omg2(ip0,jp0,kp2) = omg2(ip0,jp0,kp2) + g3*coef
+ omg3(ip0,jp0,kp2) = omg3(ip0,jp0,kp2) + g4*coef
+
+ coef=a0*b0*c3
+ omg1(ip0,jp0,kp3) = omg1(ip0,jp0,kp3) + g2*coef
+ omg2(ip0,jp0,kp3) = omg2(ip0,jp0,kp3) + g3*coef
+ omg3(ip0,jp0,kp3) = omg3(ip0,jp0,kp3) + g4*coef
+
+ coef=a0*b1*c0
+ omg1(ip0,jp1,kp0) = omg1(ip0,jp1,kp0) + g2*coef
+ omg2(ip0,jp1,kp0) = omg2(ip0,jp1,kp0) + g3*coef
+ omg3(ip0,jp1,kp0) = omg3(ip0,jp1,kp0) + g4*coef
+
+ coef=a0*b1*c1
+ omg1(ip0,jp1,kp1) = omg1(ip0,jp1,kp1) + g2*coef
+ omg2(ip0,jp1,kp1) = omg2(ip0,jp1,kp1) + g3*coef
+ omg3(ip0,jp1,kp1) = omg3(ip0,jp1,kp1) + g4*coef
+
+ coef=a0*b1*c2
+ omg1(ip0,jp1,kp2) = omg1(ip0,jp1,kp2) + g2*coef
+ omg2(ip0,jp1,kp2) = omg2(ip0,jp1,kp2) + g3*coef
+ omg3(ip0,jp1,kp2) = omg3(ip0,jp1,kp2) + g4*coef
+
+ coef=a0*b1*c3
+ omg1(ip0,jp1,kp3) = omg1(ip0,jp1,kp3) + g2*coef
+ omg2(ip0,jp1,kp3) = omg2(ip0,jp1,kp3) + g3*coef
+ omg3(ip0,jp1,kp3) = omg3(ip0,jp1,kp3) + g4*coef
+
+ coef=a0*b2*c0
+ omg1(ip0,jp2,kp0) = omg1(ip0,jp2,kp0) + g2*coef
+ omg2(ip0,jp2,kp0) = omg2(ip0,jp2,kp0) + g3*coef
+ omg3(ip0,jp2,kp0) = omg3(ip0,jp2,kp0) + g4*coef
+
+ coef=a0*b2*c1
+ omg1(ip0,jp2,kp1) = omg1(ip0,jp2,kp1) + g2*coef
+ omg2(ip0,jp2,kp1) = omg2(ip0,jp2,kp1) + g3*coef
+ omg3(ip0,jp2,kp1) = omg3(ip0,jp2,kp1) + g4*coef
+
+ coef=a0*b2*c2
+ omg1(ip0,jp2,kp2) = omg1(ip0,jp2,kp2) + g2*coef
+ omg2(ip0,jp2,kp2) = omg2(ip0,jp2,kp2) + g3*coef
+ omg3(ip0,jp2,kp2) = omg3(ip0,jp2,kp2) + g4*coef
+
+
+ coef=a0*b2*c3
+ omg1(ip0,jp2,kp3) = omg1(ip0,jp2,kp3) + g2*coef
+ omg2(ip0,jp2,kp3) = omg2(ip0,jp2,kp3) + g3*coef
+ omg3(ip0,jp2,kp3) = omg3(ip0,jp2,kp3) + g4*coef
+
+ coef=a0*b3*c0
+ omg1(ip0,jp3,kp0) = omg1(ip0,jp3,kp0) + g2*coef
+ omg2(ip0,jp3,kp0) = omg2(ip0,jp3,kp0) + g3*coef
+ omg3(ip0,jp3,kp0) = omg3(ip0,jp3,kp0) + g4*coef
+
+ coef=a0*b3*c1
+ omg1(ip0,jp3,kp1) = omg1(ip0,jp3,kp1) + g2*coef
+ omg2(ip0,jp3,kp1) = omg2(ip0,jp3,kp1) + g3*coef
+ omg3(ip0,jp3,kp1) = omg3(ip0,jp3,kp1) + g4*coef
+
+ coef=a0*b3*c2
+ omg1(ip0,jp3,kp2) = omg1(ip0,jp3,kp2) + g2*coef
+ omg2(ip0,jp3,kp2) = omg2(ip0,jp3,kp2) + g3*coef
+ omg3(ip0,jp3,kp2) = omg3(ip0,jp3,kp2) + g4*coef
+
+ coef=a0*b3*c3
+ omg1(ip0,jp3,kp3) = omg1(ip0,jp3,kp3) + g2*coef
+ omg2(ip0,jp3,kp3) = omg2(ip0,jp3,kp3) + g3*coef
+ omg3(ip0,jp3,kp3) = omg3(ip0,jp3,kp3) + g4*coef
+
+ coef=a1*b0*c0
+ omg1(ip1,jp0,kp0) = omg1(ip1,jp0,kp0) + g2*coef
+ omg2(ip1,jp0,kp0) = omg2(ip1,jp0,kp0) + g3*coef
+ omg3(ip1,jp0,kp0) = omg3(ip1,jp0,kp0) + g4*coef
+
+ coef=a1*b0*c1
+ omg1(ip1,jp0,kp1) = omg1(ip1,jp0,kp1) + g2*coef
+ omg2(ip1,jp0,kp1) = omg2(ip1,jp0,kp1) + g3*coef
+ omg3(ip1,jp0,kp1) = omg3(ip1,jp0,kp1) + g4*coef
+
+ coef=a1*b0*c2
+ omg1(ip1,jp0,kp2) = omg1(ip1,jp0,kp2) + g2*coef
+ omg2(ip1,jp0,kp2) = omg2(ip1,jp0,kp2) + g3*coef
+ omg3(ip1,jp0,kp2) = omg3(ip1,jp0,kp2) + g4*coef
+
+ coef=a1*b0*c3
+ omg1(ip1,jp0,kp3) = omg1(ip1,jp0,kp3) + g2*coef
+ omg2(ip1,jp0,kp3) = omg2(ip1,jp0,kp3) + g3*coef
+ omg3(ip1,jp0,kp3) = omg3(ip1,jp0,kp3) + g4*coef
+
+ coef=a1*b1*c0
+ omg1(ip1,jp1,kp0) = omg1(ip1,jp1,kp0) + g2*coef
+ omg2(ip1,jp1,kp0) = omg2(ip1,jp1,kp0) + g3*coef
+ omg3(ip1,jp1,kp0) = omg3(ip1,jp1,kp0) + g4*coef
+
+ coef=a1*b1*c1
+ omg1(ip1,jp1,kp1) = omg1(ip1,jp1,kp1) + g2*coef
+ omg2(ip1,jp1,kp1) = omg2(ip1,jp1,kp1) + g3*coef
+ omg3(ip1,jp1,kp1) = omg3(ip1,jp1,kp1) + g4*coef
+
+ coef=a1*b1*c2
+ omg1(ip1,jp1,kp2) = omg1(ip1,jp1,kp2) + g2*coef
+ omg2(ip1,jp1,kp2) = omg2(ip1,jp1,kp2) + g3*coef
+ omg3(ip1,jp1,kp2) = omg3(ip1,jp1,kp2) + g4*coef
+
+ coef=a1*b1*c3
+ omg1(ip1,jp1,kp3) = omg1(ip1,jp1,kp3) + g2*coef
+ omg2(ip1,jp1,kp3) = omg2(ip1,jp1,kp3) + g3*coef
+ omg3(ip1,jp1,kp3) = omg3(ip1,jp1,kp3) + g4*coef
+
+ coef=a1*b2*c0
+ omg1(ip1,jp2,kp0) = omg1(ip1,jp2,kp0) + g2*coef
+ omg2(ip1,jp2,kp0) = omg2(ip1,jp2,kp0) + g3*coef
+ omg3(ip1,jp2,kp0) = omg3(ip1,jp2,kp0) + g4*coef
+
+ coef=a1*b2*c1
+ omg1(ip1,jp2,kp1) = omg1(ip1,jp2,kp1) + g2*coef
+ omg2(ip1,jp2,kp1) = omg2(ip1,jp2,kp1) + g3*coef
+ omg3(ip1,jp2,kp1) = omg3(ip1,jp2,kp1) + g4*coef
+
+ coef=a1*b2*c2
+ omg1(ip1,jp2,kp2) = omg1(ip1,jp2,kp2) + g2*coef
+ omg2(ip1,jp2,kp2) = omg2(ip1,jp2,kp2) + g3*coef
+ omg3(ip1,jp2,kp2) = omg3(ip1,jp2,kp2) + g4*coef
+
+ coef=a1*b2*c3
+ omg1(ip1,jp2,kp3) = omg1(ip1,jp2,kp3) + g2*coef
+ omg2(ip1,jp2,kp3) = omg2(ip1,jp2,kp3) + g3*coef
+ omg3(ip1,jp2,kp3) = omg3(ip1,jp2,kp3) + g4*coef
+
+ coef=a1*b3*c0
+ omg1(ip1,jp3,kp0) = omg1(ip1,jp3,kp0) + g2*coef
+ omg2(ip1,jp3,kp0) = omg2(ip1,jp3,kp0) + g3*coef
+ omg3(ip1,jp3,kp0) = omg3(ip1,jp3,kp0) + g4*coef
+
+ coef=a1*b3*c1
+ omg1(ip1,jp3,kp1) = omg1(ip1,jp3,kp1) + g2*coef
+ omg2(ip1,jp3,kp1) = omg2(ip1,jp3,kp1) + g3*coef
+ omg3(ip1,jp3,kp1) = omg3(ip1,jp3,kp1) + g4*coef
+
+ coef=a1*b3*c2
+ omg1(ip1,jp3,kp2) = omg1(ip1,jp3,kp2) + g2*coef
+ omg2(ip1,jp3,kp2) = omg2(ip1,jp3,kp2) + g3*coef
+ omg3(ip1,jp3,kp2) = omg3(ip1,jp3,kp2) + g4*coef
+
+ coef=a1*b3*c3
+ omg1(ip1,jp3,kp3) = omg1(ip1,jp3,kp3) + g2*coef
+ omg2(ip1,jp3,kp3) = omg2(ip1,jp3,kp3) + g3*coef
+ omg3(ip1,jp3,kp3) = omg3(ip1,jp3,kp3) + g4*coef
+
+ coef=a2*b0*c0
+ omg1(ip2,jp0,kp0) = omg1(ip2,jp0,kp0) + g2*coef
+ omg2(ip2,jp0,kp0) = omg2(ip2,jp0,kp0) + g3*coef
+ omg3(ip2,jp0,kp0) = omg3(ip2,jp0,kp0) + g4*coef
+
+ coef=a2*b0*c1
+ omg1(ip2,jp0,kp1) = omg1(ip2,jp0,kp1) + g2*coef
+ omg2(ip2,jp0,kp1) = omg2(ip2,jp0,kp1) + g3*coef
+ omg3(ip2,jp0,kp1) = omg3(ip2,jp0,kp1) + g4*coef
+
+ coef=a2*b0*c2
+ omg1(ip2,jp0,kp2) = omg1(ip2,jp0,kp2) + g2*coef
+ omg2(ip2,jp0,kp2) = omg2(ip2,jp0,kp2) + g3*coef
+ omg3(ip2,jp0,kp2) = omg3(ip2,jp0,kp2) + g4*coef
+
+ coef=a2*b0*c3
+ omg1(ip2,jp0,kp3) = omg1(ip2,jp0,kp3) + g2*coef
+ omg2(ip2,jp0,kp3) = omg2(ip2,jp0,kp3) + g3*coef
+ omg3(ip2,jp0,kp3) = omg3(ip2,jp0,kp3) + g4*coef
+
+ coef=a2*b1*c0
+ omg1(ip2,jp1,kp0) = omg1(ip2,jp1,kp0) + g2*coef
+ omg2(ip2,jp1,kp0) = omg2(ip2,jp1,kp0) + g3*coef
+ omg3(ip2,jp1,kp0) = omg3(ip2,jp1,kp0) + g4*coef
+
+ coef=a2*b1*c1
+ omg1(ip2,jp1,kp1) = omg1(ip2,jp1,kp1) + g2*coef
+ omg2(ip2,jp1,kp1) = omg2(ip2,jp1,kp1) + g3*coef
+ omg3(ip2,jp1,kp1) = omg3(ip2,jp1,kp1) + g4*coef
+
+ coef=a2*b1*c2
+ omg1(ip2,jp1,kp2) = omg1(ip2,jp1,kp2) + g2*coef
+ omg2(ip2,jp1,kp2) = omg2(ip2,jp1,kp2) + g3*coef
+ omg3(ip2,jp1,kp2) = omg3(ip2,jp1,kp2) + g4*coef
+
+ coef=a2*b1*c3
+ omg1(ip2,jp1,kp3) = omg1(ip2,jp1,kp3) + g2*coef
+ omg2(ip2,jp1,kp3) = omg2(ip2,jp1,kp3) + g3*coef
+ omg3(ip2,jp1,kp3) = omg3(ip2,jp1,kp3) + g4*coef
+
+ coef=a2*b2*c0
+ omg1(ip2,jp2,kp0) = omg1(ip2,jp2,kp0) + g2*coef
+ omg2(ip2,jp2,kp0) = omg2(ip2,jp2,kp0) + g3*coef
+ omg3(ip2,jp2,kp0) = omg3(ip2,jp2,kp0) + g4*coef
+
+ coef=a2*b2*c1
+ omg1(ip2,jp2,kp1) = omg1(ip2,jp2,kp1) + g2*coef
+ omg2(ip2,jp2,kp1) = omg2(ip2,jp2,kp1) + g3*coef
+ omg3(ip2,jp2,kp1) = omg3(ip2,jp2,kp1) + g4*coef
+
+ coef=a2*b2*c2
+ omg1(ip2,jp2,kp2) = omg1(ip2,jp2,kp2) + g2*coef
+ omg2(ip2,jp2,kp2) = omg2(ip2,jp2,kp2) + g3*coef
+ omg3(ip2,jp2,kp2) = omg3(ip2,jp2,kp2) + g4*coef
+
+ coef=a2*b2*c3
+ omg1(ip2,jp2,kp3) = omg1(ip2,jp2,kp3) + g2*coef
+ omg2(ip2,jp2,kp3) = omg2(ip2,jp2,kp3) + g3*coef
+ omg3(ip2,jp2,kp3) = omg3(ip2,jp2,kp3) + g4*coef
+
+ coef=a2*b3*c0
+ omg1(ip2,jp3,kp0) = omg1(ip2,jp3,kp0) + g2*coef
+ omg2(ip2,jp3,kp0) = omg2(ip2,jp3,kp0) + g3*coef
+ omg3(ip2,jp3,kp0) = omg3(ip2,jp3,kp0) + g4*coef
+
+ coef=a2*b3*c1
+ omg1(ip2,jp3,kp1) = omg1(ip2,jp3,kp1) + g2*coef
+ omg2(ip2,jp3,kp1) = omg2(ip2,jp3,kp1) + g3*coef
+ omg3(ip2,jp3,kp1) = omg3(ip2,jp3,kp1) + g4*coef
+
+ coef=a2*b3*c2
+ omg1(ip2,jp3,kp2) = omg1(ip2,jp3,kp2) + g2*coef
+ omg2(ip2,jp3,kp2) = omg2(ip2,jp3,kp2) + g3*coef
+ omg3(ip2,jp3,kp2) = omg3(ip2,jp3,kp2) + g4*coef
+
+ coef=a2*b3*c3
+ omg1(ip2,jp3,kp3) = omg1(ip2,jp3,kp3) + g2*coef
+ omg2(ip2,jp3,kp3) = omg2(ip2,jp3,kp3) + g3*coef
+ omg3(ip2,jp3,kp3) = omg3(ip2,jp3,kp3) + g4*coef
+
+ coef=a3*b0*c0
+ omg1(ip3,jp0,kp0) = omg1(ip3,jp0,kp0) + g2*coef
+ omg2(ip3,jp0,kp0) = omg2(ip3,jp0,kp0) + g3*coef
+ omg3(ip3,jp0,kp0) = omg3(ip3,jp0,kp0) + g4*coef
+
+ coef=a3*b0*c1
+ omg1(ip3,jp0,kp1) = omg1(ip3,jp0,kp1) + g2*coef
+ omg2(ip3,jp0,kp1) = omg2(ip3,jp0,kp1) + g3*coef
+ omg3(ip3,jp0,kp1) = omg3(ip3,jp0,kp1) + g4*coef
+
+ coef=a3*b0*c2
+ omg1(ip3,jp0,kp2) = omg1(ip3,jp0,kp2) + g2*coef
+ omg2(ip3,jp0,kp2) = omg2(ip3,jp0,kp2) + g3*coef
+ omg3(ip3,jp0,kp2) = omg3(ip3,jp0,kp2) + g4*coef
+
+ coef=a3*b0*c3
+ omg1(ip3,jp0,kp3) = omg1(ip3,jp0,kp3) + g2*coef
+ omg2(ip3,jp0,kp3) = omg2(ip3,jp0,kp3) + g3*coef
+ omg3(ip3,jp0,kp3) = omg3(ip3,jp0,kp3) + g4*coef
+
+ coef=a3*b1*c0
+ omg1(ip3,jp1,kp0) = omg1(ip3,jp1,kp0) + g2*coef
+ omg2(ip3,jp1,kp0) = omg2(ip3,jp1,kp0) + g3*coef
+ omg3(ip3,jp1,kp0) = omg3(ip3,jp1,kp0) + g4*coef
+
+ coef=a3*b1*c1
+ omg1(ip3,jp1,kp1) = omg1(ip3,jp1,kp1) + g2*coef
+ omg2(ip3,jp1,kp1) = omg2(ip3,jp1,kp1) + g3*coef
+ omg3(ip3,jp1,kp1) = omg3(ip3,jp1,kp1) + g4*coef
+
+ coef=a3*b1*c2
+ omg1(ip3,jp1,kp2) = omg1(ip3,jp1,kp2) + g2*coef
+ omg2(ip3,jp1,kp2) = omg2(ip3,jp1,kp2) + g3*coef
+ omg3(ip3,jp1,kp2) = omg3(ip3,jp1,kp2) + g4*coef
+
+ coef=a3*b1*c3
+ omg1(ip3,jp1,kp3) = omg1(ip3,jp1,kp3) + g2*coef
+ omg2(ip3,jp1,kp3) = omg2(ip3,jp1,kp3) + g3*coef
+ omg3(ip3,jp1,kp3) = omg3(ip3,jp1,kp3) + g4*coef
+
+ coef=a3*b2*c0
+ omg1(ip3,jp2,kp0) = omg1(ip3,jp2,kp0) + g2*coef
+ omg2(ip3,jp2,kp0) = omg2(ip3,jp2,kp0) + g3*coef
+ omg3(ip3,jp2,kp0) = omg3(ip3,jp2,kp0) + g4*coef
+
+ coef=a3*b2*c1
+ omg1(ip3,jp2,kp1) = omg1(ip3,jp2,kp1) + g2*coef
+ omg2(ip3,jp2,kp1) = omg2(ip3,jp2,kp1) + g3*coef
+ omg3(ip3,jp2,kp1) = omg3(ip3,jp2,kp1) + g4*coef
+
+ coef=a3*b2*c2
+ omg1(ip3,jp2,kp2) = omg1(ip3,jp2,kp2) + g2*coef
+ omg2(ip3,jp2,kp2) = omg2(ip3,jp2,kp2) + g3*coef
+ omg3(ip3,jp2,kp2) = omg3(ip3,jp2,kp2) + g4*coef
+
+ coef=a3*b2*c3
+ omg1(ip3,jp2,kp3) = omg1(ip3,jp2,kp3) + g2*coef
+ omg2(ip3,jp2,kp3) = omg2(ip3,jp2,kp3) + g3*coef
+ omg3(ip3,jp2,kp3) = omg3(ip3,jp2,kp3) + g4*coef
+
+ coef=a3*b3*c0
+ omg1(ip3,jp3,kp0) = omg1(ip3,jp3,kp0) + g2*coef
+ omg2(ip3,jp3,kp0) = omg2(ip3,jp3,kp0) + g3*coef
+ omg3(ip3,jp3,kp0) = omg3(ip3,jp3,kp0) + g4*coef
+
+ coef=a3*b3*c1
+ omg1(ip3,jp3,kp1) = omg1(ip3,jp3,kp1) + g2*coef
+ omg2(ip3,jp3,kp1) = omg2(ip3,jp3,kp1) + g3*coef
+ omg3(ip3,jp3,kp1) = omg3(ip3,jp3,kp1) + g4*coef
+
+ coef=a3*b3*c2
+ omg1(ip3,jp3,kp2) = omg1(ip3,jp3,kp2) + g2*coef
+ omg2(ip3,jp3,kp2) = omg2(ip3,jp3,kp2) + g3*coef
+ omg3(ip3,jp3,kp2) = omg3(ip3,jp3,kp2) + g4*coef
+
+ coef=a3*b3*c3
+ omg1(ip3,jp3,kp3) = omg1(ip3,jp3,kp3) + g2*coef
+ omg2(ip3,jp3,kp3) = omg2(ip3,jp3,kp3) + g3*coef
+ omg3(ip3,jp3,kp3) = omg3(ip3,jp3,kp3) + g4*coef
+
+ end DO
+
+end SUBROUTINE remesh_om
diff --git a/CodesEnVrac/CodeGH/src-sphere/stretch.f90 b/CodesEnVrac/CodeGH/src-sphere/stretch.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9350e91c352384fca47843c38a5a6ad09c128b65
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/stretch.f90
@@ -0,0 +1,64 @@
+subroutine stretch
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dxinv=1./(12.*dx)
+ dyinv=1./(12.*dy)
+ dzinv=1./(12.*dz)
+
+ do k=1,nz
+ kt=mod(k+nz,nz)+1
+ kb=mod(k-2+nz,nz)+1
+ ktt=mod(k+1+nz,nz)+1
+ kbb=mod(k-3+nz,nz)+1
+ !
+ do j=1,ny
+ jt=mod(j+ny,ny)+1
+ jb=mod(j-2+ny,ny)+1
+ jtt=mod(j+1+ny,ny)+1
+ jbb=mod(j-3+ny,ny)+1
+ !
+ do i=1,nx
+ it=mod(i+nx,nx)+1
+ ib=mod(i-2+nx,nx)+1
+ itt=mod(i+1+nx,nx)+1
+ ibb=mod(i-3+nx,nx)+1
+
+ aux1=omg1(itt,j,k)*vxg(itt,j,k)+8.*(omg1(ib,j,k)*vxg(ib,j,k)-&
+ omg1(it,j,k)*vxg(it,j,k))-omg1(ibb,j,k)*vxg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vxg(i,jtt,k)+8.*(omg2(i,jb,k)*vxg(i,jb,k)-&
+ omg2(i,jt,k)*vxg(i,jt,k))-omg2(i,jbb,k)*vxg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vxg(i,j,ktt)+8.*(omg3(i,j,kb)*vxg(i,j,kb)-&
+ omg3(i,j,kt)*vxg(i,j,kt))-omg3(i,j,kbb)*vxg(i,j,kbb)
+
+ ! strg1(i,j,k)=strg1(i,j,k)-aux1*dxinv-aux2*dyinv-aux3*dzinv
+ strg1(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+
+ aux1=omg1(itt,j,k)*vyg(itt,j,k)+8.*(omg1(ib,j,k)*vyg(ib,j,k)-&
+ omg1(it,j,k)*vyg(it,j,k))-omg1(ibb,j,k)*vyg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vyg(i,jtt,k)+8.*(omg2(i,jb,k)*vyg(i,jb,k)-&
+ omg2(i,jt,k)*vyg(i,jt,k))-omg2(i,jbb,k)*vyg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vyg(i,j,ktt)+8.*(omg3(i,j,kb)*vyg(i,j,kb)-&
+ omg3(i,j,kt)*vyg(i,j,kt))-omg3(i,j,kbb)*vyg(i,j,kbb)
+
+ ! strg2(i,j,k)=strg2(i,j,k)-aux1*dxinv-aux2*dyinv-aux3*dzinv
+ strg2(i,j,k)=-aux1*dxinv-aux2*dyinv-aux3*dzinv
+ !
+ aux1=omg1(itt,j,k)*vzg(itt,j,k)+8.*(omg1(ib,j,k)*vzg(ib,j,k)-&
+ omg1(it,j,k)*vzg(it,j,k))-omg1(ibb,j,k)*vzg(ibb,j,k)
+ aux2=omg2(i,jtt,k)*vzg(i,jtt,k)+8.*(omg2(i,jb,k)*vzg(i,jb,k)-&
+ omg2(i,jt,k)*vzg(i,jt,k))-omg2(i,jbb,k)*vzg(i,jbb,k)
+ aux3=omg3(i,j,ktt)*vzg(i,j,ktt)+8.*(omg3(i,j,kb)*vzg(i,j,kb)-&
+ omg3(i,j,kt)*vzg(i,j,kt))-omg3(i,j,kbb)*vzg(i,j,kbb)
+
+ ! strg3(i,j,k)=strg3(i,j,k)-aux1*dxinv-aux2*dyinv-aux3*dzinv
+ strg3(i,j,k)=aux1*dxinv-aux2*dyinv-aux3*dzinv
+
+ enddo
+ enddo
+ enddo
+
+ return
+end subroutine stretch
diff --git a/CodesEnVrac/CodeGH/src-sphere/velox_dif.f90 b/CodesEnVrac/CodeGH/src-sphere/velox_dif.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f26b70778983e6f0a5c39b34cac494c19e570e98
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/velox_dif.f90
@@ -0,0 +1,144 @@
+ subroutine velox_dif(npart,anu,delt,xp1,yp1,zp1,om1,om2,om3,dv1,omax2)
+
+! calcul fft pour vitesses ET diffusion
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),yp1(*),zp1(*),dv1(*)
+ dimension om1(*),om2(*),om3(*)
+
+
+ dimension aux3(npg,npg,npg),aux1(npg,npg,npg),aux2(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,cox,coy,coz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cox(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ coz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ wk(ngx2+1,npgy,npgz)
+
+ pi=3.1415926
+ dxinv=0.5/dx
+ dyinv=dxinv
+ dzinv=dxinv
+
+! calucl de fonction courants 3d
+
+ nx2=nx/2
+ ny2=ny/2
+ nz2=nz/2
+
+
+ call fftw3d(omg1,cfx,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg2,cfy,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg3,cfz,nx,ny,nz,nx2,ny2,nz2,wk,0)
+
+
+! coeff de normalisation pour laplacien en spectral
+
+ anudt=anu*delt
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nz2,nz2
+ rk=float(k)*ak
+ do 10 j=1-ny2,ny2
+ rj=float(j)*aj
+ do 10 i=0,nx2
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ r2b=(1.+r2*anudt)
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+! diffusion en fourier
+ cox(i,j,k)=cfx(i,j,k)/r2b
+ coy(i,j,k)=cfy(i,j,k)/r2b
+ coz(i,j,k)=cfz(i,j,k)/r2b
+ if (r2.ne.0.) then
+! vitesses en fourier
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ endif
+10 continue
+
+! fourrier inverse pour vitesses
+ call fftw3d(aux1,cux,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,cuy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,cuz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+! fourier inverse pour vorticite apres difusion
+! et creation de particules
+
+ call fftw3d(aux1,cox,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,coy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,coz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+
+ circlim=0.0001
+ npart=0
+ vol=dx**3
+ omax1=0.
+ omax2=0.
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ omg1(i,j,k)=aux1(i,j,k)
+ omg2(i,j,k)=aux2(i,j,k)
+ omg3(i,j,k)=aux3(i,j,k)
+ strength=abs(omg2(i,j,k))+abs(omg1(i,j,k))+abs(omg3(i,j,k))
+ if ((strength.gt.circlim)) then
+ x=xmin+float(i-1)*dx
+ y=xmin+float(j-1)*dx
+ z=xmin+float(k-1)*dx
+ npart=npart+1
+ xp1(npart)=x
+ yp1(npart)=y
+ zp1(npart)=z
+ dv1(npart)=dx**3
+ om1(npart)=omg1(i,j,k)*vol
+ om2(npart)=omg2(i,j,k)*vol
+ om3(npart)=omg3(i,j,k)*vol
+ endif
+ omax2=amax1(omax2,abs(omg1(i,j,k)))
+ omax2=amax1(omax2,abs(omg2(i,j,k)))
+ omax2=amax1(omax2,abs(omg3(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+ print*, 'OMAX avant et apres DIFF ',omax1,omax2
+
+
+
+
+ return
+ end
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/velox_fft.f90 b/CodesEnVrac/CodeGH/src-sphere/velox_fft.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c6513cdb43c626f1a8b705fabc9a9ff391d80784
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/velox_fft.f90
@@ -0,0 +1,86 @@
+subroutine velox_fft
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension aux3(npg,npg,npg),aux1(npg,npg,npg),aux2(npg,npg,npg)
+
+ parameter(ngx2=npgx/2,ngy2=npgy/2,ngz2=npgz/2)
+
+ complex cfx,cfy,cfz,cux,cuy,cuz,wk
+ common/fft/cfx(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cfz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cux(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cuy(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ cuz(0:ngx2,1-ngy2:ngy2,1-ngz2:ngz2),&
+ wk(ngx2+1,npgy,npgz)
+
+ pi=3.1415926
+ dxinv=0.5/dx
+ dyinv=dxinv
+ dzinv=dxinv
+
+ ! calucl de fonction courants 3d
+
+ nx2=nx/2
+ ny2=ny/2
+ nz2=nz/2
+
+
+ call fftw3d(omg1,cfx,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg2,cfy,nx,ny,nz,nx2,ny2,nz2,wk,0)
+ call fftw3d(omg3,cfz,nx,ny,nz,nx2,ny2,nz2,wk,0)
+
+
+ ! coeff de normalisation pour laplacien en spectral
+
+ ai=2.*pi/(xmax-xmin)
+ aj=2.*pi/(ymax-ymin)
+ ak=2.*pi/(zmax-zmin)
+
+ ai2=ai**2
+ aj2=aj**2
+ ak2=ak**2
+
+ do 10 k=1-nz2,nz2
+ rk=float(k)*ak
+ do 10 j=1-ny2,ny2
+ rj=float(j)*aj
+ do 10 i=0,nx2
+ ri=float(i)*ai
+ r2=ri**2+rj**2+rk**2
+ cux(i,j,k)=cmplx(0.0,0.0)
+ cuy(i,j,k)=cmplx(0.0,0.0)
+ cuz(i,j,k)=cmplx(0.0,0.0)
+ if (r2.ne.0.) then
+ !
+ cux(i,j,k)=cmplx(0.0,1.0)*(-rj*cfz(i,j,k)+rk*cfy(i,j,k))/r2
+ cuy(i,j,k)=cmplx(0.0,1.0)*(-rk*cfx(i,j,k)+ri*cfz(i,j,k))/r2
+ cuz(i,j,k)=cmplx(0.0,1.0)*(-ri*cfy(i,j,k)+rj*cfx(i,j,k))/r2
+ endif
+10 continue
+
+
+ call fftw3d(aux1,cux,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux2,cuy,nx,ny,nz,nx2,ny2,nz2,wk,1)
+ call fftw3d(aux3,cuz,nx,ny,nz,nx2,ny2,nz2,wk,1)
+
+
+ do k=1,nx
+ do j=1,ny
+ do i=1,nz
+ vxg(i,j,k)=-aux1(i,j,k)
+ vyg(i,j,k)=-aux2(i,j,k)
+ vzg(i,j,k)=-aux3(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+
+
+ return
+ end do
+
diff --git a/CodesEnVrac/CodeGH/src-sphere/vfix.f90 b/CodesEnVrac/CodeGH/src-sphere/vfix.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d1909a857743d9f3e069c164cbaebbcda50311ef
--- /dev/null
+++ b/CodesEnVrac/CodeGH/src-sphere/vfix.f90
@@ -0,0 +1,46 @@
+ subroutine vfix
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+
+ pi=3.1415926
+ topi=2./pi
+ eps=dx/1000.
+
+! calcul vitesse moyenne dans obstacle
+
+ aire=(xmax-xmin)**2
+ total=0.
+ aux=0.
+ do k=1,nz
+ do j=1,ny
+ aux=aux+vxg(1,j,k)*dx*dx
+ enddo
+ enddo
+
+ corec=(aux-1.)/aire
+
+ aux=aux/total
+
+ vmax=0.
+ do i=1,nx
+ do j=1,ny
+ do k=1,nz
+ vxg(i,j,k)=vxg(i,j,k)-corec
+ vmax=amax1(vmax,abs(vxg(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+101 continue
+
+ print*,' VMAX = ',vmax
+
+ return
+ end
+
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_2d/Makefile b/CodesEnVrac/CodesAdrien/split_2d/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..b2ad1583c132376fed0cfea4fd236b723449aa5b
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/Makefile
@@ -0,0 +1,25 @@
+#
+# Makefile
+#
+#Compilateur = ifort
+Compilateur = ifort -pg
+#Compilateur = ifort -O0 -debug extended
+Programme = split_2d
+FILES = donnees_mod.f90 donnees_limit_mod.f90 tab_mod.f90 init_mod.f90 remaillage_mod.f90 interpolation_mod.f90 advection_mod.f90 utile_mod.f90 resultats_mod.f90 main.f90
+OBJS = $(patsubst %.f90, %.o, $(FILES))
+
+$(Programme): $(OBJS)
+ @echo edition de liens
+ @$(Compilateur) $(OBJS) -o $@
+
+%.o: %.f90
+ @echo compilation de $?
+ @$(Compilateur) -c $?
+
+clean:
+ @rm -f *.o *~ *.mod
+ @echo nettoyage
+
+clean_all:
+ @rm -f *.o *~ *.mod *exe *.out
+ @echo nettoyage
diff --git a/CodesEnVrac/CodesAdrien/split_2d/Makefile_old b/CodesEnVrac/CodesAdrien/split_2d/Makefile_old
new file mode 100644
index 0000000000000000000000000000000000000000..a3cce3640c8ecba9939730ae988a610f99fe0d4d
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/Makefile_old
@@ -0,0 +1,27 @@
+#
+# Makefile
+#
+Compilateur = ifort
+Programme = limit_flux
+OBJS = donnees_mod.f90 donnees_limit_mod.f90 tab_mod.f90 init_mod.f90 advection_mod.f90 remaillage_mod.f90 resultats_mod.f90 utile_mod.f90 interpolation_mod.f90 v_moy_mod.f90 main.f90
+
+#interpolation_mod.f90 derives_mod.f90
+
+$(Programme): $(OBJS)
+ @echo edition de liens
+ @$(Compilateur) $(OBJS) -o $@
+
+.f90.o:
+ @echo compilation de $?
+ @$(Compilateur) -c -O $?
+
+.c.o:
+ @c -c -O $?
+ @echo compilation de $?
+clean:
+ @rm -f *.o *~ *.mod
+ @echo nettoyage
+
+clean_all:
+ @rm -f *.o *~ *.mod *exe *.out
+ @echo nettoyage
diff --git a/CodesEnVrac/CodesAdrien/split_2d/advection_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/advection_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..de520926217234862dba09e64c6fdacf70a913d3
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/advection_mod.f90
@@ -0,0 +1,555 @@
+module advection_mod
+ use donnees_mod
+ use tab_mod
+ use remaillage_mod
+ use interpolation_mod
+contains
+
+ subroutine def_v_advec (vitx,vity,tps)
+ implicit none
+ real(kind=8),dimension(1:nx_gro,1:ny_gro),intent(out) :: vitx,vity
+ real(kind=8),intent(in) :: tps
+ integer :: i,j
+ real(kind=8) :: x,y,r2,tmp,cte,r,alpha,beta,rint,rext,w1,w2,w3,t1,t4,t5
+
+
+ do j=1,ny_gro
+ do i=1,nx_gro
+
+ x=xg+(i-1)*dx_gro
+ y=yb+(j-1)*dy_gro
+
+
+!!$ !rotation avec chgmt signe
+!!$ !-------------------------
+!!$ r2=x**2+y**2
+!!$ !tmp=1
+!!$ tmp=cos(3.*0.5*pi*sqrt(r2))
+!!$ !tmp=cos(10.*sqrt(r2))
+!!$ vitx(i,j)=-tmp*y
+!!$ vity(i,j)=tmp*x
+
+!!$ !test Staniforth sur [0,100]**2
+!!$ !----
+!!$ vitx(i,j)=8.*pi*sin(pi*x/25.)*sin(pi*y/25.)/25.
+!!$ vity(i,j)=8.*pi*cos(pi*x/25.)*cos(pi*y/25.)/25.
+
+ !Staniforth sur [0,1] avec retour pour t=0.5
+ !--------------------------------------------
+!!$ vitx(i,j)=0.08*pi*sin(4.*pi*x)*sin(4.*pi*y)/(cos(2.*pi*tps)/4.)
+!!$ vity(i,j)=0.08*pi*cos(4.*pi*x)*cos(4.*pi*y)/(cos(2.*pi*tps)/4.)
+!!$
+
+ !filaments
+ !----------
+!!$ t1=10.
+!!$
+!!$ vitx(i,j)=-2.*sin(pi*x)**2*sin(pi*y)*cos(pi*y) !*cos(pi*tps/t1)
+!!$ vity(i,j)=2.*sin(pi*y)**2*sin(pi*x)*cos(pi*x) !*cos(pi*tps/t1)
+
+
+
+ !test instationaire
+ !--------------------
+
+!!$ t1=1.
+!!$ t4=0.3
+!!$ t5=1.
+!!$
+!!$ vitx(i,j)=t5*sin(2.*pi*x/t1)*sin(2.*pi*y/t1)*cos(pi*tps/t4)
+!!$ vity(i,j)=t5*cos(2.*pi*x/t1)*cos(2.*pi*y/t1)*cos(pi*tps/t4)
+
+
+ !vitesse radiale
+ !----------------
+ r=sqrt(x**2+y**2)
+ vitx(i,j)=x/r
+ vity(i,j)=y/r
+
+ if (r<0.4) then
+ vitx(i,j)=x/0.4
+ vity(i,j)=y/0.4
+ end if
+
+
+
+ end do
+ end do
+
+end subroutine def_v_advec
+
+
+subroutine evalv (vitx,vity,tps,x,y)
+ implicit none
+ real(kind=8),intent(in) :: tps,x,y
+ real(kind=8),intent(out) :: vitx,vity
+ integer :: i,j
+ real(kind=8) :: r2,tmp,cte,r,alpha,beta,rint,rext,w1,w2,w3,t1,t4,t5
+
+
+ t1=1.
+ t4=0.3
+ t5=1.
+
+ vitx=t5*sin(2.*pi*x/t1)*sin(2.*pi*y/t1)*cos(pi*tps/t4)
+ vity=t5*cos(2.*pi*x/t1)*cos(2.*pi*y/t1)*cos(pi*tps/t4)
+
+end subroutine evalv
+
+
+
+
+
+
+
+
+ subroutine crea_part_x
+ implicit none
+ integer :: i,j
+ real(kind=8) :: x,y,m
+
+ m=cutoff*maxval(abs(qg))
+ npart=0
+ numpg=0
+ do j=1,ny
+ do i=1,nx
+ x=xtab(i,j)
+ y=ytab(i,j)
+
+ if (abs(qg(i,j))>=m) then
+ npart=npart+1
+ numpg(i,j)=npart
+ xp(npart)=x
+ yp(npart)=y
+ vx(npart)=vxg(i,j)
+ vy(npart)=vyg(i,j)
+ !vx(npart)=interpol_v_l3(vxg,x,y)
+ !vy(npart)=interpol_v_l3(vyg,x,y)
+ qp(npart)=qg(i,j)
+ end if
+ end do
+ end do
+
+ end subroutine crea_part_x
+
+ subroutine crea_part_y
+ implicit none
+ integer :: i,j
+ real(kind=8) :: x,y,m
+
+ m=cutoff*maxval(abs(qg))
+ npart=0
+ numpg=0
+ do i=1,nx
+ do j=1,ny
+ x=xtab(i,j)
+ y=ytab(i,j)
+
+ if (abs(qg(i,j))>=m) then
+ npart=npart+1
+ numpg(i,j)=npart
+ xp(npart)=x
+ yp(npart)=y
+ vx(npart)=vxg(i,j)
+ vy(npart)=vyg(i,j)
+ !vx(npart)=interpol_v_l3(vxg,x,y)
+ !vy(npart)=interpol_v_l3(vyg,x,y)
+ qp(npart)=qg(i,j)
+ end if
+ end do
+ end do
+
+ end subroutine crea_part_y
+
+
+ !==================
+ !TENSORIEL
+ !==================
+
+ subroutine ad_tenso_euler
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ xp(i)=xp(i)+dt*vx(i)
+ yp(i)=yp(i)+dt*vy(i)
+ end do
+
+ end subroutine ad_tenso_euler
+
+ subroutine ad_tenso_rk2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+
+ call interpo_l2_2d(vxg,xp1,yp1,vx)
+ call interpo_l2_2d(vyg,xp1,yp1,vy)
+
+ !call interpo_l3_2d(vxg1,xp1,yp1,vx)
+ !call interpo_l3_2d(vyg1,xp1,yp1,vy)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*vx(ib)
+ yp(ib)=yp(ib)+dt*vy(ib)
+ end do
+
+ deallocate(xp1,yp1)
+
+ end subroutine ad_tenso_rk2
+
+
+
+
+
+
+ subroutine ad_tenso_rk3
+ implicit none
+ integer :: ib
+
+
+ allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vy1(1:npart),vy2(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+
+ call interpo_l3_2d(vxg1,xp1,yp1,vx1)
+ call interpo_l3_2d(vyg1,xp1,yp1,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)-dt*vx(ib)+2.*dt*vx1(ib)
+ yp2(ib)=yp(ib)-dt*vy(ib)+2.*dt*vy1(ib)
+ end do
+
+ call interpo_l3_2d(vxg2,xp2,yp2,vx2)
+ call interpo_l3_2d(vyg2,xp2,yp2,vy2)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*(vx(ib)/6.+2.*vx1(ib)/3.+vx2(ib)/6.)
+ yp(ib)=yp(ib)+dt*(vy(ib)/6.+2.*vy1(ib)/3.+vy2(ib)/6.)
+ end do
+
+ deallocate (xp1,xp2,yp1,yp2)
+ deallocate (vx1,vx2,vy1,vy2)
+
+
+ end subroutine ad_tenso_rk3
+
+
+ subroutine ad_tenso_rk4
+ implicit none
+ integer :: ib
+
+
+ allocate (xp1(1:npart),xp2(1:npart),xp3(1:npart),yp1(1:npart),yp2(1:npart),yp3(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vx3(1:npart),vy1(1:npart),vy2(1:npart),vy3(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+
+ call interpo_l4_2d(vxg1,xp1,yp1,vx1)
+ call interpo_l4_2d(vyg1,xp1,yp1,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+0.5*dt*vx1(ib)
+ yp2(ib)=yp(ib)+0.5*dt*vy1(ib)
+ end do
+
+ call interpo_l4_2d(vxg1,xp2,yp2,vx2)
+ call interpo_l4_2d(vyg1,xp2,yp2,vy2)
+
+ do ib=1,npart
+ xp3(ib)=xp(ib)+dt*vx2(ib)
+ yp3(ib)=yp(ib)+dt*vy2(ib)
+ end do
+
+ call interpo_l4_2d(vxg2,xp3,yp3,vx3)
+ call interpo_l4_2d(vyg2,xp3,yp3,vy3)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*(vx(ib)+2.*vx1(ib)+2.*vx2(ib)+vx3(ib))/6.
+ yp(ib)=yp(ib)+dt*(vy(ib)+2.*vy1(ib)+2.*vy2(ib)+vy3(ib))/6.
+ end do
+
+ deallocate (xp1,xp2,xp3,yp1,yp2,yp3)
+ deallocate (vx1,vx2,vx3,vy1,vy2,vy3)
+
+
+ end subroutine ad_tenso_rk4
+
+
+ !===============================
+ !ADVECTION non tensoriel
+ !===============================
+
+ subroutine ad_euler_x
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ xp(i)=xp(i)+dt*vx(i)
+ end do
+
+ end subroutine ad_euler_x
+
+ subroutine ad_euler_y
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ yp(i)=yp(i)+dt*vy(i)
+ end do
+
+ end subroutine ad_euler_y
+
+
+ !===============================
+ !SPLITTING
+ !calcul de la vitesse pour une advection d'euler à l'ordre 2 ou 3
+ !===============================
+
+ subroutine update_vx_2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+ !call interpo_l2_2d(vxg1,xp1,yp1,vx)
+ call interpo_l2_2d(vxg,xp1,yp1,vx)
+ deallocate(xp1,yp1)
+
+ end subroutine update_vx_2
+
+ subroutine update_vy_2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)-0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+ !call interpo_l2_2d(vyg1,xp1,yp1,vy)
+ call interpo_l2_2d(vyg,xp1,yp1,vy)
+ deallocate(xp1,yp1)
+
+ end subroutine update_vy_2
+
+
+
+ subroutine update_vx_3
+ implicit none
+ integer :: ib
+
+
+ allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vy1(1:npart),vy2(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+2.*dt*vx(ib)/3.
+ yp1(ib)=yp(ib)+2.*dt*vy(ib)/3.
+ end do
+
+ !call interpo_l3_2d(vxg2,xp1,yp1,vx1)
+ !call interpo_l3_2d(vyg2,xp1,yp1,vy1)
+ call interpo_l3_2d(vxg,xp1,yp1,vx1)
+ call interpo_l3_2d(vyg,xp1,yp1,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)/4.+vx1(ib)/4.)
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+vy1(ib))
+ end do
+
+ !call interpo_l3_2d(vxg,xp2,yp,vx2)
+ !call interpo_l3_2d(vxg,xp,yp2,vy2)
+ call interpo_l3_2d(vxg,xp2,yp,vx2)
+ call interpo_l3_2d(vxg,xp,yp2,vy2)
+
+ do ib=1,npart
+ vx(ib)=-vx(ib)+3.*vx1(ib)/4.+vx2(ib)+vy2(ib)/4.
+ end do
+
+ deallocate (xp1,xp2,yp1,yp2)
+ deallocate (vx1,vx2,vy1,vy2)
+
+
+ end subroutine update_vx_3
+
+ subroutine update_vy_3
+ implicit none
+ integer :: ib,i,j
+
+ allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart))
+ allocate (xp0(1:npart))
+ allocate (vx1(1:npart),vy1(1:npart),vy2(1:npart),vy3(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)-2.*dt*vx(ib)/3.
+ yp1(ib)=yp(ib)+dt*vy(ib)/3.
+ xp0(ib)=xp(ib)-dt*vx(ib)/6.
+ end do
+
+ !call interpo_l3_2d(vxg1,xp0,yp1,vx1)
+ !call interpo_l3_2d(vyg1,xp1,yp1,vy1)
+ call interpo_l3_2d(vxg,xp0,yp1,vx1)
+ call interpo_l3_2d(vyg,xp1,yp1,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(vx(ib)-vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+2.*vy1(ib))
+ end do
+
+ !call interpo_l3_2d(vyg,xp2,yp,vy2)
+ !call interpo_l3_2d(vyg3,xp,yp2,vy3)
+ call interpo_l3_2d(vyg,xp2,yp,vy2)
+ call interpo_l3_2d(vyg,xp,yp2,vy3)
+
+ do ib=1,npart
+ vy(ib)=-vy(ib)+3.*vy1(ib)/4.+vy2(ib)+vy3(ib)/4.
+ end do
+
+
+ deallocate (xp1,xp2,yp1,yp2)
+ deallocate (xp0)
+ deallocate (vx1,vy1,vy2,vy3)
+
+ end subroutine update_vy_3
+
+
+
+
+
+ !==================================
+ !STRANG
+ !==================================
+
+ subroutine update_vx_strang
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+dt*vx(ib)/2.
+ end do
+ !call interpo_l3_2d(vxg1,xp1,yp,vx)
+ call interpo_l3_2d(vxg,xp1,yp,vx)
+ deallocate(xp1)
+
+ end subroutine update_vx_strang
+
+ subroutine update_vy_strang
+ implicit none
+ integer :: ib
+
+ allocate (yp1(1:npart))
+ do ib=1,npart
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+ !call interpo_l3_2d(vyg1,xp,yp1,vy)
+ call interpo_l3_2d(vyg,xp,yp1,vy)
+ deallocate(yp1)
+
+ end subroutine update_vy_strang
+
+
+ !==================================
+ !ordre 4
+ !==================================
+
+ subroutine update_vx_4
+ implicit none
+ integer :: ib
+
+
+ allocate (xp1(1:npart),xp2(1:npart),xp3(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vx3(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ end do
+
+ call interpo_l5_2d(vxg,xp1,yp,vx1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+0.5*dt*vx1(ib)
+ end do
+
+ call interpo_l5_2d(vxg,xp2,yp,vx2)
+
+ do ib=1,npart
+ xp3(ib)=xp(ib)+dt*vx2(ib)
+ end do
+
+ call interpo_l5_2d(vxg,xp3,yp,vx3)
+
+ do ib=1,npart
+ vx(ib)=(vx(ib)+2.*vx1(ib)+2.*vx2(ib)+vx3(ib))/6.
+ end do
+
+ deallocate (xp1,xp2,xp3)
+ deallocate (vx1,vx2,vx3)
+
+ end subroutine update_vx_4
+
+
+ subroutine update_vy_4
+ implicit none
+ integer :: ib
+
+
+ allocate (yp1(1:npart),yp2(1:npart),yp3(1:npart))
+ allocate (vy1(1:npart),vy2(1:npart),vy3(1:npart))
+
+ do ib=1,npart
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+
+ call interpo_l5_2d(vyg,xp,yp1,vy1)
+
+ do ib=1,npart
+ yp2(ib)=yp(ib)+0.5*dt*vy1(ib)
+ end do
+
+ call interpo_l5_2d(vyg,xp,yp2,vy2)
+
+ do ib=1,npart
+ yp3(ib)=yp(ib)+dt*vy2(ib)
+ end do
+
+ call interpo_l5_2d(vyg,xp,yp3,vy3)
+
+ do ib=1,npart
+ vy(ib)=(vy(ib)+2.*vy1(ib)+2.*vy2(ib)+vy3(ib))/6.
+ end do
+
+ deallocate (yp1,yp2,yp3)
+ deallocate (vy1,vy2,vy3)
+
+
+ end subroutine update_vy_4
+
+
+
+
+end module advection_mod
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_2d/donnees_limit_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/donnees_limit_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ba181a33caa771332159b07e5d8d04aacfef0cbb
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/donnees_limit_mod.f90
@@ -0,0 +1,5 @@
+module donnees_limit_mod
+
+ real(kind=8),dimension(-6:6):: q_tab,q_tab_p,q_tab_m,v_tab_m,v_tab_p,l_tab_p,l_tab_m,h_tab_p,h_tab_m
+
+end module donnees_limit_mod
diff --git a/CodesEnVrac/CodesAdrien/split_2d/donnees_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/donnees_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aff193869feb85ff11f0efa45c2a8e0a25669b93
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/donnees_mod.f90
@@ -0,0 +1,9 @@
+module donnees_mod
+
+ integer :: nx,ny,nx_gro,ny_gro,npart,type_b,long_bloc,int_limit
+ real(kind=8) :: time,dx,xd_f,xd_g,xg,dt,dt_sauv,tfin,cfl,pi,dt_b
+ real(kind=8) :: yb,yh_f,yh_g,dy,cutoff,dx_gro,dy_gro
+ character(len=50) :: nom_fich_vtk
+
+
+end module donnees_mod
diff --git a/CodesEnVrac/CodesAdrien/split_2d/init_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/init_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a3e1ce4e8d8b82944d1a261c6d16ded7cfeee87d
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/init_mod.f90
@@ -0,0 +1,144 @@
+module init_mod
+ !
+ !initialisation des valeurs sur la grille
+ !
+contains
+ subroutine init_grille
+ use donnees_mod
+ use tab_mod
+ implicit none
+ integer :: i,j
+ real(kind=8) :: x,y,xt,yt,beta,t1,t2,t3,r
+
+ !---gaussienne---------
+ !-----------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=(1.-(x**2+y**2))**6
+!!$ if ((x**2+y**2)>1.) qg(i,j)=0.
+!!$
+!!$
+!!$ end do
+!!$ end do
+
+ !---gaussienne pour Staniford sur [0,1]^2-----------
+ !----------------------------------------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=0.
+!!$
+!!$ qg(i,j)=(1.-((x-0.5)**2+(y-0.5)**2))**6
+!!$ if (((x-0.5)**2+(y-0.5)**2)>1.) qg(i,j)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ !---test sur [0,1]^2-----------
+!!$ !----------------------------------------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=0.
+!!$
+!!$ qg(i,j)=(1.-((x-0.5)**2+(y-0.5)**2))**2
+!!$ if (((x-0.5)**2+(y-0.5)**2)>1.) qg(i,j)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+ !---constante-----------
+ !-----------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=1.
+!!$ if ((x**2+y**2)>1.) qg(i,j)=0.
+!!$ end do
+!!$ end do
+!!$
+!!$ !---gaussienne pour filaments sur [0,1]^2-----------
+!!$ !----------------------------------------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=0.
+!!$
+!!$ qg(i,j)=(1.-((x-0.5)**2+(y-0.8)**2))**6
+!!$ if (((x-0.5)**2+(y-0.5)**2)>1.) qg(i,j)=0.
+!!$
+!!$ end do
+!!$ end do
+
+
+ !---cercle pour filaments sur [0,1]^2-----------
+ !----------------------------------------------------
+
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=0.
+!!$
+!!$ if (sqrt((x-0.5)**2+(y-0.75)**2)<=0.15) qg(i,j)=1.
+!!$
+!!$ end do
+!!$ end do
+
+
+ !-----------Analytique en cos--------------------------
+ !------------------------------------------------------
+!!$ t1=1.
+!!$ t2=1.
+!!$ t3=0.2
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ qg(i,j)=cos(pi*time/t3)*cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ end do
+!!$ end do
+
+ !---anneau-----------
+ !-----------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ r=sqrt(x**2+y**2)
+!!$ qg(i,j)=0.
+!!$ !if ( (r>0.5).and.(r<1.4) ) qg(i,j)=1.
+!!$ !if ( (r>0.).and.(r<0.8) ) qg(i,j)=1.
+!!$ !if ( (r>=1.).and.(r<1.5) ) qg(i,j)=1.
+!!$ if ( (r>0.5).and.(r<1.) ) qg(i,j)=1.
+!!$ end do
+!!$ end do
+
+ !---anneau- regulier----------
+ !-----------------------
+ do i=1,nx
+ do j=1,ny
+ x=xtab(i,j)
+ y=ytab(i,j)
+ r=sqrt(x**2+y**2)
+ qg(i,j)=0.
+ if ( (r>0.4).and.(r<0.6) ) qg(i,j)=-512.+5400.*r-22500.*r**2+46250*r**3-46875*r**4+18750*r**5
+ if ( (r>=0.6).and.(r<=0.8) ) qg(i,j)=1.
+ if ( (r>0.8).and.(r<1.) ) qg(i,j)=10625.-60000*r+135000*r**2-151250*r**3+84375*r**4-18750*r**5
+
+ !if ( (r>0.4).and.(r<1.) ) qg(i,j)=1.
+ end do
+ end do
+
+
+ end subroutine init_grille
+
+
+
+end module init_mod
diff --git a/CodesEnVrac/CodesAdrien/split_2d/interpolation_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/interpolation_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a3b4048dcd3d919196dfda6edb51251e640ddd4b
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/interpolation_mod.f90
@@ -0,0 +1,634 @@
+module interpolation_mod
+ use donnees_mod
+ contains
+
+
+ subroutine interpo_l4_2d(tab_grille,posx,posy,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:5) :: ip,jp
+ real(kind=8),dimension(0:5) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy_gro-yb)/dy_gro !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ if (yy1<=0.5) then
+ poidy(0)=(2.*yy1-y2-2*y3+y4)/24.
+ poidy(1)=(-4.*yy1+4.*y2+y3-y4)/6.
+ poidy(2)=1.+(-5.*y2+y4)/4.
+ poidy(3)=(4.*yy1+4.*y2-y3-y4)/6.
+ poidy(4)=(-2.*yy1-y2+2*y3+y4)/24.
+ poidy(5)=0.
+ else
+ poidy(0)=0.
+ poidy(1)=(-6.*yy1+11.*y2-6.*y3+y4)/24.
+ poidy(2)=1.+(-5.*yy1-5.*y2+5.*y3-y4)/6.
+ poidy(3)=(6.*yy1+y2-4.*y3+y4)/4.
+ poidy(4)=(-3.*yy1+y2+3.*y3-y4)/6.
+ poidy(5)=(2.*yy1-y2-2.*y3+y4)/24.
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ do d=0,5
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine interpo_l4_2d
+
+ subroutine interpo_l5_2d(tab_grille,posx,posy,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:5) :: ip,jp
+ real(kind=8),dimension(0:5) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy_gro-yb)/dy_gro !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ poidy(0)=yy1/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(1)=-yy1/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(2)=1.-yy1/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(3)=yy1+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(4)=-yy1/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(5)=yy1/30.-y3/24.+y5/120.
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ do d=0,5
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine interpo_l5_2d
+
+
+
+ subroutine interpo_l3_2d(tab_grille,posx,posy,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:3) :: ip,jp
+ real(kind=8),dimension(0:3) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ poidy(0)=-1./6.*yy1*(yy1-1.)*(yy1-2.)
+ poidy(1)=0.5*(1.-yy1)*(1.+yy1)*(2.-yy1)
+ poidy(2)=-0.5*yy1*(yy1+1.)*(yy1-2.)
+ poidy(3)=1/6.*yy1*(1.+yy1)*(yy1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ do d=0,3
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine interpo_l3_2d
+
+
+ subroutine interpo_l2_2d(tab_grille,posx,posy,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:2) :: ip,jp
+ real(kind=8),dimension(0:2) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=0.5*xx1*(xx1-1.)
+ poidx(1)=1.-xx1**2
+ poidx(2)=0.5*xx1*(1.+xx1)
+
+ poidy(0)=0.5*yy1*(yy1-1.)
+ poidy(1)=1.-yy1**2
+ poidy(2)=0.5*yy1*(1.+yy1)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,2
+ do d=0,2
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine interpo_l2_2d
+
+ subroutine interpo_l1_2d(tab_grille,posx,posy,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb
+ integer,dimension(1:2) :: ip,jp
+ real(kind=8),dimension(1:2) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ tab_part=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(2) = ip(1) + 1
+
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(2) = jp(1) + 1
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=1,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=1,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(1)=1.-xx1
+ poidx(2)=xx1
+
+ poidy(1)=1.-yy1
+ poidy(2)=yy1
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,2
+ do d=1,2
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine interpo_l1_2d
+
+
+
+
+
+ !===========================================================================
+ !pour interpoler le champ de vitesse de la grille grossiere à la grille fine
+ !===========================================================================
+
+
+ function interpol_v_l1(tab_gro,posx,posy) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy
+ real(kind=8) :: v
+ integer,dimension(0:1) :: ip,jp
+ real(kind=8),dimension(0:1) :: poidx,poidy
+ real(kind=8) :: xx,yy
+ integer :: c,d
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(1) = ip(0)+1
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(1) = jp(0)+1
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,1
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,1
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=1.-xx
+ poidx(1)=xx
+
+ poidy(0)=1.-yy
+ poidy(1)=yy
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,1
+ do d=0,1
+ v=v+tab_gro(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+
+ end function interpol_v_l1
+
+ function interpol_v_l3(tab_gro,posx,posy) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy
+ real(kind=8) :: v
+ integer,dimension(-1:2) :: ip,jp
+ real(kind=8),dimension(-1:2) :: poidx,poidy
+ real(kind=8) :: xx,yy
+ integer :: c,d
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-1,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(-1)=-1./6.*xx*(xx-1.)*(xx-2.)
+ poidx(0)=0.5*(1.-xx)*(1.+xx)*(2.-xx)
+ poidx(1)=-0.5*xx*(xx+1.)*(xx-2.)
+ poidx(2)=1/6.*xx*(1.+xx)*(xx-1.)
+
+ poidy(-1)=-1./6.*yy*(yy-1.)*(yy-2.)
+ poidy(0)=0.5*(1.-yy)*(1.+yy)*(2.-yy)
+ poidy(1)=-0.5*yy*(yy+1.)*(yy-2.)
+ poidy(2)=1/6.*yy*(1.+yy)*(yy-1.)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-1,2
+ do d=-1,2
+ v=v+tab_gro(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+
+ end function interpol_v_l3
+
+ function interpol_v_l5(tab_gro,posx,posy) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy
+ real(kind=8) :: v
+ integer,dimension(-2:3) :: ip,jp
+ real(kind=8),dimension(-2:3) :: poidx,poidy
+ real(kind=8) :: xx,yy
+ integer :: c,d
+ real(kind=8) :: x2,x3,x4,x5,y2,y3,y4,y5
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-2) = ip(0)-2
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+ ip(3) = ip(0)+3
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-2) = jp(0)-2
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+ jp(3) = jp(0)+3
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-2,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ x2=xx**2
+ x3=xx**3
+ x4=xx**4
+ x5=xx**5
+ y2=yy**2
+ y3=yy**3
+ y4=yy**4
+ y5=yy**5
+
+ poidx(-2)=xx/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(-1)=-xx/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(0)=1.-xx/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(1)=xx+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(2)=-xx/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(3)=xx/30.-x3/24.+x5/120.
+
+ poidy(-2)=yy/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(-1)=-yy/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(0)=1.-yy/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(1)=yy+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(2)=-yy/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(3)=yy/30.-y3/24.+y5/120.
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,3
+ do d=-2,3
+ v=v+tab_gro(ip(c)+1,jp(d)+1)*poidx(c)*poidy(d)
+ end do
+ end do
+
+ end function interpol_v_l5
+
+
+
+
+
+
+ end module interpolation_mod
diff --git a/CodesEnVrac/CodesAdrien/split_2d/main.f90 b/CodesEnVrac/CodesAdrien/split_2d/main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..84d6afbd7bd6ccbc9e6f22acaf7e31c7b7c592ef
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/main.f90
@@ -0,0 +1,1253 @@
+program split
+ !--------------------------------------------------------------------------
+ !etude de l'ordre pour splitting
+ !
+ !--------------------------------------------------------------------------
+ use donnees_mod ! donnees
+ use tab_mod ! donnees dans tableaux
+ use init_mod ! init_grille
+ use advection_mod ! crea_part,advection
+ use remaillage_mod ! remaill_4m_centre (formules de remaillage)
+ use interpolation_mod ! formules d'interpolation (pour range kutta)
+ use resultats_mod ! res_grille_tps,res_grille_freq
+ use utile_mod ! fonctions en tout genre
+
+ real(kind=8) :: x,y,dt_deb,dt_boucle,dtsauv,maxv
+ character(len=50) :: name_err,name_coupe
+ integer :: i,j,cpt_ite,ib,jb,nx_boucle
+
+ real(kind=8) :: deb,masse,t1,t2,t3
+
+
+ !lecture données
+ !---------------
+ open(unit=10,file="parameter",form="formatted")
+ read(10,*) xg,xd,yb,yh
+ read(10,*) tfin
+ read(10,*) cutoff
+ read(10,*) type_b
+ read(10,*) long_bloc
+ read(10,*) int_limit
+ read(10,*) nom_fich_vtk
+ read(10,*) name_err,name_coupe
+ close(10)
+
+
+ erreur:do nx_boucle=201,201
+ !erreur:do nx_boucle=10,5000,30
+ !erreur:do nx_boucle=10,5000,100
+ !nx=(long_bloc+1)*k+1 => bloc bord de bonne taille
+
+ open(unit=10,file="parameter",form="formatted")
+ read(10,*) xg,xd,yb,yh
+ close (10)
+
+ nx=nx_boucle
+ ny=nx_boucle
+
+ !nx_gro=nx/2
+ nx_gro=nx
+ ny_gro=nx_gro
+
+ dx=(xd-xg)/(nx-1.)
+ dy=(yh-yb)/(ny-1.)
+
+ dx_gro=(xd-xg)/(nx_gro-1.)
+ dy_gro=(yh-yb)/(ny_gro-1.)
+
+ maxv=1.
+ !maxv=2.
+ cfl=3.
+
+ dt=cfl*dx/maxv
+ !dt=0.0001
+ dt_deb=dt
+
+
+!!$
+!!$
+!!$
+!!$ erreur:do dt_b=0.2,0.01,-0.01
+!!$ !nx=(long_bloc+1)*k+1 => bloc bord de bonne taille
+!!$
+!!$ open(unit=10,file="parameter",form="formatted")
+!!$ read(10,*) xg,xd,yb,yh
+!!$ close (10)
+!!$
+!!$ nx_boucle=400
+!!$
+!!$ nx=nx_boucle
+!!$ ny=nx_boucle
+!!$
+!!$ !nx_gro=nx/2
+!!$ nx_gro=nx
+!!$ ny_gro=nx_gro
+!!$
+!!$ dx=(xd-xg)/(nx-1.)
+!!$ dy=(yh-yb)/(ny-1.)
+!!$
+!!$ dx_gro=(xd-xg)/(nx_gro-1.)
+!!$ dy_gro=(yh-yb)/(ny_gro-1.)
+!!$
+!!$
+!!$ dt=dt_b
+
+
+
+
+
+ !
+ !calcul init
+ !-----------
+ cpt_ite=0
+ time=0.
+
+
+ npart=nx*ny
+
+ xd_f=xd-dx !pour conditions periodiques
+ yh_f=yh-dy
+
+ xd_g=xd-dx_gro
+ yh_g=yh-dy_gro
+
+ nx=nx-1
+ ny=ny-1
+
+ nx_gro=nx_gro-1
+ ny_gro=ny_gro-1
+
+
+ pi=4.*atan(1.)
+
+
+
+
+
+ !
+ !alloc tableaux: ici npart est une taille maximale, on pourrait rallouer apres la creation des part.
+ !--------------
+ allocate (exa(1:nx,1:ny),qg(1:nx,1:ny),vxg(1:nx_gro,1:ny_gro),vyg(1:nx_gro,1:ny_gro))
+ allocate (xtab(1:nx,1:ny),ytab(1:nx,1:ny))
+ allocate (numpg(1:nx,1:ny))
+ !allocate (Nblocg(1:max(nx,ny)))
+
+ allocate (xp(1:npart),qp(1:npart),vx(1:npart),yp(1:npart),vy(1:npart))
+ allocate (blocg(0:npart),blocd(0:npart),Nbloc(0:npart))
+
+ open(unit=29,file=name_err,form="formatted")
+ open(unit=30,file=name_coupe,form="formatted")
+
+ call cpu_time(t1)
+
+ !
+ !initialisation
+ !--------------
+ call make_grille
+ call init_grille()
+ masse=dx*dy*sum(qg)
+
+ call def_v_advec(vxg,vyg,time)
+
+ !
+ !boucle temps
+ !------------
+ temps: do while(time<tfin)
+
+ !print*,"cflmax:",dt*max(maxval(vxg),maxval(vyg))/dx
+
+ if ((time+dt)>tfin) dt=tfin-time
+
+ if (time<=2.*dt) dt_deb=dt
+
+
+ !call def_v_advec(vxg,vyg,time) !inutile de le garder dans la boucle quand depend pas du temps.
+
+ call crea_part_x()
+
+
+
+
+ !================================
+ !si remaillage tenso en espace
+ !================================
+
+!!$ !champ de vitesse
+!!$ !-----------------
+!!$ !allocate(vxg1(1:nx_gro,1:ny_gro),vyg1(1:nx_gro,1:ny_gro))
+!!$ !rk2
+!!$ !call def_v_advec(vxg1,vyg1,time+0.5*dt)
+!!$ !vxg1=vxg
+!!$ !vyg1=vyg
+!!$
+!!$ !rk3
+!!$ !allocate(vxg2(1:nx_gro,1:ny_gro),vyg2(1:nx_gro,1:ny_gro))
+!!$ !call def_v_advec(vxg1,vyg1,time+0.5*dt)
+!!$ !call def_v_advec(vxg2,vyg2,time+dt)
+!!$ !vxg2=vxg
+!!$ !vyg2=vyg
+!!$
+!!$ !rk4
+!!$ !allocate(vxg3(1:nx_gro,1:ny_gro),vyg3(1:nx_gro,1:ny_gro))
+!!$ !vxg3=vxg
+!!$ !vyg3=vyg
+!!$
+!!$
+!!$ !t source:rk4
+!!$ !------------
+!!$ !call source_rk4
+!!$
+!!$ !advection
+!!$ !---------
+!!$ !call ad_tenso_euler
+!!$ call ad_tenso_rk2
+!!$ !call ad_tenso_rk3
+!!$ !call ad_tenso_rk4
+!!$
+!!$
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l2(qp,xp,yp,qg)
+!!$ call remaill_l3(qp,xp,yp,qg)
+!!$ !call remaill_l4(qp,xp,yp,qg)
+!!$ !call remaill_l6(qp,xp,yp,qg)
+!!$ !call remaill_mp4(qp,xp,yp,qg)
+!!$ !call remaill_mppp6(qp,xp,yp,qg)
+!!$
+!!$ !deallocate(vxg1,vyg1)
+!!$ !deallocate(vxg2,vyg2)
+!!$ !deallocate(vxg3,vyg3)
+
+ !=====================
+ !splitting en espace
+ !=====================
+
+ !champ de vitesse
+ !-----------------
+ !allocate(vxg1(1:nx_gro,1:ny_gro),vyg1(1:nx_gro,1:ny_gro))
+ !rk2
+ !call def_v_advec(vxg1,vyg1,time+0.5*dt)
+ !vxg1=vxg
+ !vyg1=vyg ! attention sinon modifier dans les update vitesses d'advection
+
+ !rk3
+ !allocate(vxg2(1:nx_gro,1:ny_gro),vxg3(1:nx_gro,1:ny_gro),vyg2(1:nx_gro,1:ny_gro),vyg3(1:nx_gro,1:ny_gro))
+ !call def_v_advec(vxg1,vyg1,time+dt/3.)
+ !call def_v_advec(vxg2,vyg2,time+2.*dt/3.)
+ !call def_v_advec(vxg3,vyg3,time+dt) !que le vyg3 qui nous interesse
+ !vxg2=vxg;vxg3=vxg
+ !vyg2=vyg;vyg3=vyg
+
+
+ !t source
+ !---------
+ !call source_split_1
+
+ !update v
+ !--------
+ !call update_vx_2
+ call update_vx_3
+
+
+ !test cfl
+ !--------
+ !print*,"test cfl en x "
+ !print*,"cfl part, cfl",dt/dx*maxval(abs(vx)),dt/dx*maxval(abs(vxg))
+
+ !print*,"max vx",maxval(vx)
+
+! ainf=0.
+! do j=1,ny
+! do i=1,nx-1
+! if ( (numpg(i+1,j)/=0).and.(numpg(i,j)/=0) ) ainf=max(ainf,abs(vx(numpg(i+1,j))-vx(numpg(i,j))))
+! end do
+! end do
+! if (dt>(0.5*dx/(ainf))) then
+! print*,""
+! print*,"cfl l2 viole" ,dt,0.5*dx/(ainf),0.5*dx/(2.*ainf)
+! print*,""
+! end if
+! if (dt>(0.5*dx/(2.*ainf))) then
+! print*,""
+! print*,"cfl l4 viole" ,dt,0.5*dx/(ainf),0.5*dx/(2.*ainf)
+! print*,"dx,dt",dx,dt
+! print*,""
+! end if
+! if (dt>(dx/(2.*ainf/(sqrt(3.)-1.)))) then
+! print*,""
+! print*,"TSC gauche pas TVD (l2)" ,dt,dx/(2.*ainf/(sqrt(3.)-1.))
+! print*,""
+! end if
+! if (dt>(dx/(5.4641*ainf))) then
+! print*,""
+! print*,"TSC gauche pas TVD (l4)" ,dt,dx/(2.*ainf/(sqrt(3.)-1.))
+! print*,""
+! end if
+! print*,"ainf",ainf/dx
+! print*,"max",maxval(vx)
+ !fin test
+ !--------
+
+
+ !bloc x
+ !-------
+ if ((type_b==2).or.(type_b==4)) then
+ !call make_bloc(1)
+ call make_bloc_v2(1)
+ else
+ blocg=0
+ blocd=0
+ end if
+
+ !advection
+ !----------
+ call ad_euler_x
+
+
+ !remaillage
+ !----------
+ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+ if (type_b==70)call remaill_mp4_x(qp,xp,yp,qg)
+ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+ if (type_b==2) then
+ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+ end if
+ if (type_b==4) then
+ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+ end if
+
+ if (type_b==200)call remaill_l2_limit_x(qp,xp,yp,qg)
+ if (type_b==400)call remaill_l4_limit_x(qp,xp,yp,qg)
+
+ !y
+ !--
+ call crea_part_y()
+
+ !update v
+ !--------
+ !call update_vy_2
+ call update_vy_3
+
+
+ !test cfl
+ !--------
+ !print*,"test cfl en y "
+ !print*,"cfl part, cfl",dt/dy*maxval(abs(vy)),dt/dy*maxval(abs(vyg))
+! ainf=0.
+! do j=1,ny-1
+! do i=1,nx
+! if ( (numpg(i,j+1)/=0).and.(numpg(i,j)/=0) ) ainf=max(ainf,abs(vy(numpg(i,j+1))-vy(numpg(i,j))))
+! end do
+! end do
+! if (dt>(0.5*dy/(ainf))) then
+! print*,""
+! print*,"cfl l2 viole" ,dt,0.5*dy/(ainf),0.5*dy/(2.*ainf)
+! print*,""
+! end if
+! if (dt>(0.5*dy/(2.*ainf))) then
+! print*,""
+! print*,"cfl l4 viole" ,dt,0.5*dy/(ainf),0.5*dy/(2.*ainf)
+! print*,""
+! end if
+ !fin test
+ !--------
+
+ !bloc y
+ !-------
+ if ((type_b==2).or.(type_b==4)) then
+ !call make_bloc(2)
+ call make_bloc_v2(2)
+ else
+ blocg=0
+ blocd=0
+ end if
+
+ !advection
+ !----------
+ call ad_euler_y
+
+
+
+!-------test----------------------------------------
+! if (cpt_ite <=1) then
+!
+! !trace la position des particules
+! open(unit=28,file="RES/pos_part.deb",form="formatted")
+! open(unit=29,file="RES/pos_part_2.deb",form="formatted")
+! do ib=1,nx
+! x=xg+(ib-1)*dx
+! if ( (x>0.8).and.(x<0.81) ) then
+! do jb=1,(ny+10)
+! y=yb+(jb-1)*dy
+! write(28,'(2(f35.20,2x))') y,0.5
+! end do
+! end if
+! end do
+!
+! do ib=1,npart
+! if ((xp(ib)>0.8).and.(xp(ib)<0.81)) then
+! write(29,'(4(f35.20,2x))') yp(ib),0.5,blocg(ib)*0.1 ,blocd(ib)*0.1
+! end if
+! end do
+!
+! close (28)
+! close (29)
+!
+! end if
+!-------test----------------------------------------
+
+!!$
+ !remaillage
+ !----------
+ if (type_b==30)call remaill_l3_y(qp,xp,yp,qg)
+ if (type_b==40)call remaill_l4_y(qp,xp,yp,qg)
+ if (type_b==20)call remaill_l2_y(qp,xp,yp,qg)
+ if (type_b==50)call remaill_l5_y(qp,xp,yp,qg)
+ if (type_b==60)call remaill_l6_y(qp,xp,yp,qg)
+ if (type_b==70)call remaill_mp4_y(qp,xp,yp,qg)
+ !if (type_b==2)call remaill_l2_bloc_y(qp,xp,yp,qg)
+ !if (type_b==4)call remaill_l4_bloc_y(qp,xp,yp,qg)
+ if (type_b==2) then
+ if (int_limit==0)call remaill_l2_bloc_v2_y(qp,xp,yp,qg)
+ if (int_limit==1)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+ end if
+ if (type_b==4) then
+ if (int_limit==0)call remaill_l4_bloc_v2_y(qp,xp,yp,qg)
+ if (int_limit==1)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+ end if
+
+ if (type_b==200)call remaill_l2_limit_y(qp,xp,yp,qg)
+ if (type_b==400)call remaill_l4_limit_y(qp,xp,yp,qg)
+
+ !t source
+ !---------
+ !call source_split_2
+
+
+ !deallocate(vxg1,vyg1)
+ !deallocate(vxg2,vxg3,vyg2,vyg3)
+
+
+
+ !=================
+ !splitting strang
+ !=================
+!!$
+!!$ !champ de vitesse:
+!!$ !-----------------
+!!$ allocate(vxg1(1:nx_gro,1:ny_gro),vyg1(1:nx_gro,1:ny_gro))
+!!$ !call def_v_advec(vxg1,vyg1,time+0.5*dt)
+!!$ vxg1=vxg
+!!$ vyg1=vyg
+!!$
+!!$ !t source
+!!$ !--------
+!!$ !call source_split_1
+!!$
+!!$ dt_sauv=dt
+!!$ dt=0.5*dt
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_strang
+!!$
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ !call make_bloc_x
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ call remaill_l3_x(qp,xp,yp,qg)
+!!$ !call remaill_l5_x(qp,xp,yp,qg)
+!!$ !call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2)call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$
+!!$ !y
+!!$ !--
+!!$ call crea_part_y()
+!!$
+!!$
+!!$ dt=dt_sauv
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_strang
+!!$
+!!$ !test cfl
+!!$ !--------
+!!$ !ainf=0.
+!!$ !do i=1,nx
+!!$ ! do j=1,ny-1
+!!$ ! ainf=max(ainf,abs(vyg(i,j+1)-vyg(i,j)))
+!!$ ! end do
+!!$ !end do
+!!$ !print*,"dt,limit vg",dt,dy/(4.*ainf),dy/(6.*ainf)
+!!$ !ainf=0.
+!!$ !do i=1,nx
+!!$ ! do j=1,ny-1
+!!$ ! ainf=max(ainf,abs(vy(numpg(i,j+1))-vy(numpg(i,j))))
+!!$ ! end do
+!!$ !end do
+!!$ !print*,"dt,limit v",dt,dy/(4.*ainf),dy/(6.*ainf)
+!!$
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ !call make_bloc_y
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ call remaill_l3_y(qp,xp,yp,qg)
+!!$ !call remaill_l5_y(qp,xp,yp,qg)
+!!$ !call remaill_l6_y(qp,xp,yp,qg)
+!!$ !if (type_b==2)call remaill_l2_bloc_y(qp,xp,yp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_y(qp,xp,yp,qg)
+!!$
+!!$ !x
+!!$ !--
+!!$ call crea_part_x()
+!!$
+!!$ dt_sauv=dt
+!!$ dt=0.5*dt
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_strang
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ !call make_bloc_x
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ call remaill_l3_x(qp,xp,yp,qg)
+!!$ !call remaill_l5_x(qp,xp,yp,qg)
+!!$ !call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2)call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$
+!!$ dt=dt_sauv
+!!$ !t source
+!!$ !---------
+!!$ !call source_split_2
+!!$
+!!$
+!!$ deallocate(vxg1,vyg1)
+
+
+
+
+
+
+
+
+ !=============================
+ !splitting ordre 4 en temps
+ !==============================
+!!$ allocate(qg_init(1:nx,1:ny),qg_tmp(1:nx,1:ny))
+!!$ qg_init=qg
+!!$!====================
+!!$! x: dt/4
+!!$!====================
+!!$
+!!$ dt_sauv=dt
+!!$ dt=0.25*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_4
+!!$
+!!$
+!!$
+!!$ !test cfl
+!!$ !--------
+!!$ !print*,"test cfl en x "
+!!$ !ainf=0.
+!!$ !do j=1,ny
+!!$ ! do i=1,nx-1
+!!$ ! if ( (numpg(i+1,j)/=0).and.(numpg(i,j)/=0) ) ainf=max(ainf,abs(vx(numpg(i+1,j))-vx(numpg(i,j))))
+!!$ ! end do
+!!$ !end do
+!!$ !print*,"ainf",ainf
+!!$ !fin test
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! y: dt/2
+!!$!====================
+!!$ call crea_part_y()
+!!$
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_4
+!!$
+!!$ !test cfl
+!!$ !--------
+!!$ !print*,"test cfl en y "
+!!$ !ainf=0.
+!!$ !do i=1,nx
+!!$ ! do j=1,ny-1
+!!$ ! if ( (numpg(i,j+1)/=0).and.(numpg(i,j)/=0) ) ainf=max(ainf,abs(vy(numpg(i,j+1))-vy(numpg(i,j))))
+!!$ ! end do
+!!$ !end do
+!!$ !print*,"ainf",ainf
+!!$ !fin test
+!!$
+!!$ !bloc
+!!$ !-----
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(2)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_y(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_y(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_y(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_y(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_y(qp,xp,yp,qg)
+!!$
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! x: dt/2
+!!$!====================
+!!$ call crea_part_x()
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_4
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! y: dt/2
+!!$!====================
+!!$ call crea_part_y()
+!!$
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_4
+!!$
+!!$ !bloc
+!!$ !-----
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(2)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_y(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_y(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_y(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_y(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_y(qp,xp,yp,qg)
+!!$
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$!====================
+!!$! x: dt/4
+!!$!====================
+!!$ call crea_part_x()
+!!$ dt=0.25*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_4
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$
+!!$ qg_tmp=qg
+!!$ qg=qg_init
+!!$
+!!$
+!!$!====================
+!!$! x: dt/2
+!!$!====================
+!!$ call crea_part_x()
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_4
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! y: dt
+!!$!====================
+!!$ call crea_part_y()
+!!$
+!!$ dt=dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_4
+!!$
+!!$ !bloc
+!!$ !-----
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(2)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_y(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_y(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_y(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_y(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_y(qp,xp,yp,qg)
+!!$
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! x: dt/2
+!!$!====================
+!!$ call crea_part_x()
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_4
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$ qg=(-qg+4.*qg_tmp)/3.
+!!$
+!!$
+!!$ dt=dt_sauv
+!!$ deallocate(qg_init,qg_tmp)
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$
+ !=============================
+ ! STRANG
+ !==============================
+!!$ allocate(qg_init(1:nx,1:ny),qg_tmp(1:nx,1:ny))
+!!$ qg_init=qg
+!!$!====================
+!!$! x: dt/2
+!!$!====================
+!!$
+!!$ dt_sauv=dt
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ !call update_vx_4
+!!$ call update_vx_strang
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! y: dt
+!!$!====================
+!!$ call crea_part_y()
+!!$
+!!$ dt=dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ !call update_vy_4
+!!$ call update_vy_strang
+!!$
+!!$ !bloc
+!!$ !-----
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(2)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_y(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_y(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_y(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_y(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_y(qp,xp,yp,qg)
+!!$
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_y(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_y(qp,xp,yp,qg)
+!!$
+!!$!====================
+!!$! x: dt/2
+!!$!====================
+!!$ call crea_part_x()
+!!$ dt=0.5*dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ !call update_vx_4
+!!$ call update_vx_strang
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ if ((type_b==2).or.(type_b==4)) then
+!!$ call make_bloc_v2(1)
+!!$ else
+!!$ blocg=0
+!!$ blocd=0
+!!$ end if
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ if (type_b==30) call remaill_l3_x(qp,xp,yp,qg)
+!!$ if (type_b==40) call remaill_l4_x(qp,xp,yp,qg)
+!!$ if (type_b==20) call remaill_l2_x(qp,xp,yp,qg)
+!!$ if (type_b==50)call remaill_l5_x(qp,xp,yp,qg)
+!!$ if (type_b==60)call remaill_l6_x(qp,xp,yp,qg)
+!!$ !if (type_b==2) call remaill_l2_bloc_x(qp,xp,yp,qg)
+!!$ !if (type_b==4) call remaill_l4_bloc_x(qp,xp,yp,qg)
+!!$ if (type_b==2) then
+!!$ if (int_limit==0)call remaill_l2_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$ if (type_b==4) then
+!!$ if (int_limit==0)call remaill_l4_bloc_v2_x(qp,xp,yp,qg)
+!!$ if (int_limit==1)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ end if
+!!$
+!!$ if (type_b==200)call remaill_l2_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$ if (type_b==400)call remaill_l4_bloc_v2_limit_x(qp,xp,yp,qg)
+!!$
+!!$
+!!$
+!!$ dt=dt_sauv
+!!$ deallocate(qg_init,qg_tmp)
+
+
+
+
+
+
+
+
+
+
+
+
+
+ time=time+dt
+ cpt_ite=cpt_ite+1
+
+
+ end do temps
+
+ !------------------------------
+ !sol exacte:
+ !--------------------------------
+
+ !erreur pour sol init gaussienne
+ !--------------------------------
+!!$ do i=1,nx
+!!$ do j=1,ny
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ exa(i,j)=0.
+!!$
+!!$ !exa(i,j)=(1.-((x-0.5)**2+(y-0.5)**2))**6
+!!$ !if (((x-0.5)**2+(y-0.5)**2)>1.) exa(i,j)=0.
+!!$
+!!$ exa(i,j)=(1.-((x)**2+(y)**2))**6
+!!$ if (((x)**2+(y)**2)>1.) exa(i,j)=0.
+!!$
+!!$ !exa(i,j)=1.
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ !-----------Analytique en cos--------------------------
+!!$ !------------------------------------------------------
+!!$ t1=1.
+!!$ t2=1.
+!!$ t3=0.2
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ exa(i,j)=cos(pi*time/t3)*cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ end do
+!!$ end do
+
+ !---cercle pour filaments sur [0,1]^2-----------
+ !----------------------------------------------------
+!!$
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ x=xtab(i,j)
+!!$ y=ytab(i,j)
+!!$ exa(i,j)=0.
+!!$
+!!$ if (sqrt((x-0.5)**2+(y-0.75)**2)<=0.15) exa(i,j)=1.
+!!$
+!!$ end do
+!!$ end do
+
+
+ !write(29,'(4(e18.10,2x))') dt_deb,dx,dx*dy*sum(abs(exa-qg)),sqrt(dx*dy*sum((exa-qg)**2))
+
+ !COUPE en y=1.5
+ !--------------
+ j=(1.5-yb)/dy+1
+ do i=1,nx
+ write(30,'(2(e18.10,2x))') xg+(i-1)*dx,qg(i,j)
+ end do
+
+
+ end do erreur
+ call cpu_time(t2)
+
+ !resultat final
+ !--------------
+ print*,"tps final",time
+ print*,"nbre d'ite",cpt_ite
+ print*,"nart final",npart
+ print*,"dt,dx,dy",dt_deb,dx,dy
+ print*,"max vx",maxval(abs(vxg)),maxloc(abs(vxg))
+ print*,"max vy",maxval(abs(vyg)),maxloc(abs(vxg))
+ print*,"perte masse",masse-dx*dy*sum(qg)
+ print*,"tps dexecution",t2-t1
+
+
+
+ call res_vtk("RES/vtk/"//nom_fich_vtk)
+
+
+
+ !
+ !dealloc fermeture
+ !-----------------
+ close(50)
+ close(51)
+ close(52)
+ close(53)
+ close(66)
+ close(67)
+ close(29)
+ close(30)
+
+ deallocate (xp,qp,vx,vy,yp)
+ deallocate (qg,vxg,vyg,exa)
+ deallocate (xtab,ytab)
+ deallocate (blocg,blocd)
+ deallocate (numpg,Nbloc)
+ !deallocate (Nblocg)
+
+
+
+end program split
+
+
+
+
+
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_2d/parameter b/CodesEnVrac/CodesAdrien/split_2d/parameter
new file mode 100644
index 0000000000000000000000000000000000000000..1998801abbe062f49397728b71bd4d0046f2ba0e
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/parameter
@@ -0,0 +1,8 @@
+-2 2 -2 2 ! xg xd yb yh
+0.8 2. 5. 0.05 ! TFin
+0.00001 !cutoff
+70 !type bloc
+1 !longeur des blocs
+0 ! limitation 0=non 1=oui
+"anregu_o3_cfl3_200_t08_cutm5_mp4.vtk" ! sortie fin vtk
+"RES/test.er" "RES/anregu_o3_cfl3_200_t08_cutm5_mp4.co" ! fichier erreur /coupe
\ No newline at end of file
diff --git a/CodesEnVrac/CodesAdrien/split_2d/remaillage_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/remaillage_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bbbd60860539dbf4c3ab034a2f5bcaf876c71c02
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/remaillage_mod.f90
@@ -0,0 +1,5365 @@
+module remaillage_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+
+
+
+ subroutine remaill_l3 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:3) :: ip,jp
+ real(kind=8),dimension(0:3) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ poidy(0)=-1./6.*yy1*(yy1-1.)*(yy1-2.)
+ poidy(1)=0.5*(1.-yy1)*(1.+yy1)*(2.-yy1)
+ poidy(2)=-0.5*yy1*(yy1+1.)*(yy1-2.)
+ poidy(3)=1/6.*yy1*(1.+yy1)*(yy1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ do d=0,3
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l3
+
+ subroutine remaill_l4 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:5) :: ip,jp
+ real(kind=8),dimension(0:5) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,y2,y3,y4
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ if (yy1<=0.5) then
+ poidy(0)=(2.*yy1-y2-2*y3+y4)/24.
+ poidy(1)=(-4.*yy1+4.*y2+y3-y4)/6.
+ poidy(2)=1.+(-5.*y2+y4)/4.
+ poidy(3)=(4.*yy1+4.*y2-y3-y4)/6.
+ poidy(4)=(-2.*yy1-y2+2*y3+y4)/24.
+ poidy(5)=0.
+ else
+ poidy(0)=0.
+ poidy(1)=(-6.*yy1+11.*y2-6.*y3+y4)/24.
+ poidy(2)=1.+(-5.*yy1-5.*y2+5.*y3-y4)/6.
+ poidy(3)=(6.*yy1+y2-4.*y3+y4)/4.
+ poidy(4)=(-3.*yy1+y2+3.*y3-y4)/6.
+ poidy(5)=(2.*yy1-y2-2.*y3+y4)/24.
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ do d=0,5
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine remaill_l4
+
+ subroutine remaill_mppp6 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:5) :: ip,jp
+ real(kind=8),dimension(0:5) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,y2,y3,y4
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1*x2
+ x4=xx1*x3
+
+ poidx(0)=9./88.*xx1-3./16.*x2+27./176.*x4-3./44.*xx1**5
+ poidx(1)=-31./44.*xx1+19./16.*x2-1./44.*x3-141./176.*x4+15./44.*xx1**5
+ poidx(2)=147./88.*x4-175./88.*x2+1.-15./22.*xx1**5
+ poidx(3)=31./44.*xx1+107./88.*x2+3./22.*x3-153./88.*x4+15./22.*xx1**5
+ poidx(4)=-9./88.*xx1-49./176.*x2-2./11.*x3+159./176.*x4-15./44.*xx1**5
+ poidx(5)=9./176.*x2+3./44.*x3-3./16.*x4+3./44.*xx1**5
+
+ y2=yy1**2
+ y3=yy1*y2
+ y4=yy1*y3
+
+ poidy(0)=9./88.*yy1-3./16.*y2+27./176.*y4-3./44.*yy1**5
+ poidy(1)=-31./44.*yy1+19./16.*y2-1./44.*y3-141./176.*y4+15./44.*yy1**5
+ poidy(2)=147./88.*y4-175./88.*y2+1.-15./22.*yy1**5
+ poidy(3)=31./44.*yy1+107./88.*y2+3./22.*y3-153./88.*y4+15./22.*yy1**5
+ poidy(4)=-9./88.*yy1-49./176.*y2-2./11.*y3+159./176.*y4-15./44.*yy1**5
+ poidy(5)=9./176.*y2+3./44.*y3-3./16.*y4+3./44.*yy1**5
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ do d=0,5
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+ end subroutine remaill_mppp6
+
+ subroutine remaill_l5 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:5) :: ip,jp
+ real(kind=8),dimension(0:5) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ poidy(0)=yy1/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(1)=-yy1/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(2)=1.-yy1/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(3)=yy1+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(4)=-yy1/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(5)=yy1/30.-y3/24.+y5/120.
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ do d=0,5
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l5
+
+ subroutine remaill_l6 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(-3:4) :: ip,jp
+ real(kind=8),dimension(-3:4) :: poidx,poidy
+ real(kind=8) :: xx,yy,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+ jp(0) = floor((posy(i)-yb)/dy)
+ jp(-1) = jp(0) - 1
+ jp(-2) = jp(0) - 2
+ jp(-3) = jp(0) - 3
+ jp(1) = jp(0) + 1
+ jp(2) = jp(0) + 2
+ jp(3) = jp(0) + 3
+ jp(4) = jp(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+ yy = (posy(i) - real(jp(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=-3,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-3)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/720.
+ poidx(-2)=-(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+3.)/120.
+ poidx(-1)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+2.)*(xx+3.)/48.
+ poidx(0)=-(xx-3.)*(xx-2.)*(xx-1.)*(xx+1.)*(xx+2.)*(xx+3.)/36.
+ poidx(1)=(xx-3.)*(xx-2.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/48.
+ poidx(2)=-(xx-3.)*(xx-1.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/120.
+ poidx(3)=(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/720.
+ poidx(4)=0.
+ else
+ poidx(-3)=0.
+ poidx(-2)=(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)/720.
+ poidx(-1)=-(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+2.)/120.
+ poidx(0)=(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*(xx-3.)*(xx-2.)*xx*(xx+1.)*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/120.
+ poidx(4)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/720.
+ end if
+
+ if (yy<=0.5) then
+ poidy(-3)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/720.
+ poidy(-2)=-(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+3.)/120.
+ poidy(-1)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+2.)*(yy+3.)/48.
+ poidy(0)=-(yy-3.)*(yy-2.)*(yy-1.)*(yy+1.)*(yy+2.)*(yy+3.)/36.
+ poidy(1)=(yy-3.)*(yy-2.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/48.
+ poidy(2)=-(yy-3.)*(yy-1.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/120.
+ poidy(3)=(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/720.
+ poidy(4)=0.
+ else
+ poidy(-3)=0.
+ poidy(-2)=(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)/720.
+ poidy(-1)=-(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+2.)/120.
+ poidy(0)=(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*(yy+1.)*(yy+2.)/48.
+ poidy(1)=-(yy-4.)*(yy-3.)*(yy-2.)*yy*(yy+1.)*(yy+2.)/36.
+ poidy(2)=(yy-4.)*(yy-3.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/48.
+ poidy(3)=-(yy-4.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/120.
+ poidy(4)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/720.
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ do d=-3,4
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l6
+
+ subroutine remaill_mp4 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:3) :: ip,jp
+ real(kind=8),dimension(0:3) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,x2,x3,x4,x5,y2,y3,y4,y5
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=-0.5*xx1+x2-0.5*x3
+ poidx(1)=1-5./2.*x2+3.*0.5*x3
+ poidx(2)=0.5*xx1+2.*x2-3.*0.5*x3
+ poidx(3)=-0.5*x2+0.5*x3
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+ poidy(0)=-0.5*yy1+y2-0.5*y3
+ poidy(1)=1-5./2.*y2+3.*0.5*y3
+ poidy(2)=0.5*yy1+2.*y2-3.*0.5*y3
+ poidy(3)=-0.5*y2+0.5*y3
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ do d=0,3
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_mp4
+
+ subroutine remaill_l2_g (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(0:3) :: ip,jp
+ real(kind=8),dimension(0:3) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-0.5*xx1*(1.-xx1)
+ poidx(1)=1.-xx1**2
+ poidx(2)=0.5*xx1*(1.+xx1)
+ poidx(3)=0.
+
+ poidy(0)=-0.5*yy1*(1.-yy1)
+ poidy(1)=1.-yy1**2
+ poidy(2)=0.5*yy1*(1.+yy1)
+ poidy(3)=0.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ do d=0,3
+ if ((ip(c)>-1).and.(ip(c)<nx).and.(jp(d)>-1).and.(jp(d)<ny)) then
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l2_g
+
+ subroutine remaill_l2 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(1:4) :: ip,jp
+ real(kind=8),dimension(1:4) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=1,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=1,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5) then
+
+ poidx(1)=-0.5*xx1*(1.-xx1)
+ poidx(2)=1.-xx1**2
+ poidx(3)=0.5*xx1*(1.+xx1)
+ poidx(4)=0.
+
+ else
+
+ poidx(1)=0.
+ poidx(2)=0.5*(xx1-1.)*(xx1-2.)
+ poidx(3)=xx1*(2.-xx1)
+ poidx(4)=0.5*xx1*(xx1-1.)
+
+ end if
+
+ if (yy1<=0.5) then
+
+ poidy(1)=-0.5*yy1*(1.-yy1)
+ poidy(2)=1.-yy1**2
+ poidy(3)=0.5*yy1*(1.+yy1)
+ poidy(4)=0.
+
+ else
+
+ poidy(1)=0.
+ poidy(2)=0.5*(yy1-1.)*(yy1-2.)
+ poidy(3)=yy1*(2.-yy1)
+ poidy(4)=0.5*yy1*(yy1-1.)
+
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,4
+ do d=1,4
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l2
+
+ subroutine remaill_l1 (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(1:2) :: ip,jp
+ real(kind=8),dimension(0:3) :: poidx,poidy
+ real(kind=8) :: xx1,yy1
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(2) = ip(1) + 1
+
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(2) = jp(1) + 1
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids:
+ !----------------
+ poidx(1)=(1.-xx1)
+ poidx(2)=xx1
+
+ poidy(1)=(1.-yy1)
+ poidy(2)=yy1
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,2
+ do d=1,2
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+
+ end do
+
+ end subroutine remaill_l1
+
+ subroutine remaill_tsc (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb
+ integer,dimension(1:4) :: ip,jp
+ real(kind=8),dimension(1:4) :: poidx,poidy
+ real(kind=8) :: xx1,yy1,alpha
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=1,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=1,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ alpha=1./8.
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5) then
+
+ poidx(1)=alpha-0.5*xx1+0.5*xx1**2
+ poidx(2)=(1.-2.*alpha)-xx1**2
+ poidx(3)=alpha+0.5*xx1+0.5*xx1**2
+ poidx(4)=0.
+
+ else
+
+ poidx(1)=0.
+ poidx(2)=1.+alpha-3.*0.5*xx1+0.5*xx1**2
+ poidx(3)=-2.*alpha+2.*xx1-xx1**2
+ poidx(4)=alpha-0.5*xx1+0.5*xx1**2
+
+ end if
+
+ if (yy1<=0.5) then
+
+ poidy(1)=alpha-0.5*yy1+0.5*yy1**2
+ poidy(2)=(1.-2.*alpha)-yy1**2
+ poidy(3)=alpha+0.5*yy1+0.5*yy1**2
+ poidy(4)=0.
+
+ else
+
+ poidy(1)=0.
+ poidy(2)=1.+alpha-3.*0.5*yy1+0.5*yy1**2
+ poidy(3)=-2.*alpha+2.*yy1-yy1**2
+ poidy(4)=alpha-0.5*yy1+0.5*yy1**2
+
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,4
+ do d=1,4
+ remaille(ip(c)+1,jp(d)+1)=remaille(ip(c)+1,jp(d)+1)+donne(i)*poidx(c)*poidy(d)
+ end do
+ end do
+ end do
+
+ end subroutine remaill_tsc
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ subroutine remaill_l3_x(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:3) :: ip
+ real(kind=8),dimension(0:3) :: poidx
+ real(kind=8) :: xx1,tmp_pos
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l3_x
+
+
+ subroutine remaill_l3_y(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:3) :: ip
+ real(kind=8),dimension(0:3) :: poidx
+ real(kind=8) :: xx1,tmp_pos
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(1),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l3_y
+
+
+
+
+
+
+ subroutine remaill_mp4_x(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:3) :: ip
+ real(kind=8),dimension(0:3) :: poidx
+ real(kind=8) :: xx1,tmp_pos
+ real(kind=8) :: x2,x3,x4,x5
+
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=-0.5*xx1+x2-0.5*x3
+ poidx(1)=1-5./2.*x2+3.*0.5*x3
+ poidx(2)=0.5*xx1+2.*x2-3.*0.5*x3
+ poidx(3)=-0.5*x2+0.5*x3
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_mp4_x
+
+
+ subroutine remaill_mp4_y(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:3) :: ip
+ real(kind=8),dimension(0:3) :: poidx
+ real(kind=8) :: xx1,tmp_pos
+ real(kind=8) :: x2,x3,x4,x5
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(1),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=-0.5*xx1+x2-0.5*x3
+ poidx(1)=1-5./2.*x2+3.*0.5*x3
+ poidx(2)=0.5*xx1+2.*x2-3.*0.5*x3
+ poidx(3)=-0.5*x2+0.5*x3
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,3
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_mp4_y
+
+
+
+
+
+
+ subroutine remaill_l4_x(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_x
+
+
+ subroutine remaill_l4_y(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(2),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_y
+
+ subroutine remaill_l6_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb,j
+ integer,dimension(-3:4) :: ip,jp
+ real(kind=8),dimension(-3:4) :: poidx,poidy
+ real(kind=8) :: xx,yy,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-3)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/720.
+ poidx(-2)=-(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+3.)/120.
+ poidx(-1)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+2.)*(xx+3.)/48.
+ poidx(0)=-(xx-3.)*(xx-2.)*(xx-1.)*(xx+1.)*(xx+2.)*(xx+3.)/36.
+ poidx(1)=(xx-3.)*(xx-2.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/48.
+ poidx(2)=-(xx-3.)*(xx-1.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/120.
+ poidx(3)=(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)*(xx+3.)/720.
+ poidx(4)=0.
+ else
+ poidx(-3)=0.
+ poidx(-2)=(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)/720.
+ poidx(-1)=-(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+2.)/120.
+ poidx(0)=(xx-4.)*(xx-3.)*(xx-2.)*(xx-1.)*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*(xx-3.)*(xx-2.)*xx*(xx+1.)*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/120.
+ poidx(4)=(xx-3.)*(xx-2.)*(xx-1.)*xx*(xx+1.)*(xx+2.)/720.
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+ end do
+
+ end subroutine remaill_l6_x
+
+ subroutine remaill_l6_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,jb,ivar
+ integer,dimension(-3:4) :: ip,jp
+ real(kind=8),dimension(-3:4) :: poidx,poidy
+ real(kind=8) :: xx,yy,x2,x3,x4,x5,y1,y2,y3,y4,y5
+
+ remaille=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+
+
+ jp(0) = floor((posy(i)-yb)/dy)
+ jp(-1) = jp(0) - 1
+ jp(-2) = jp(0) - 2
+ jp(-3) = jp(0) - 3
+ jp(1) = jp(0) + 1
+ jp(2) = jp(0) + 2
+ jp(3) = jp(0) + 3
+ jp(4) = jp(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ yy = (posy(i) - real(jp(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=-3,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+
+ if (yy<=0.5) then
+ poidy(-3)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/720.
+ poidy(-2)=-(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+3.)/120.
+ poidy(-1)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+2.)*(yy+3.)/48.
+ poidy(0)=-(yy-3.)*(yy-2.)*(yy-1.)*(yy+1.)*(yy+2.)*(yy+3.)/36.
+ poidy(1)=(yy-3.)*(yy-2.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/48.
+ poidy(2)=-(yy-3.)*(yy-1.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/120.
+ poidy(3)=(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)*(yy+3.)/720.
+ poidy(4)=0.
+ else
+ poidy(-3)=0.
+ poidy(-2)=(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)/720.
+ poidy(-1)=-(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+2.)/120.
+ poidy(0)=(yy-4.)*(yy-3.)*(yy-2.)*(yy-1.)*(yy+1.)*(yy+2.)/48.
+ poidy(1)=-(yy-4.)*(yy-3.)*(yy-2.)*yy*(yy+1.)*(yy+2.)/36.
+ poidy(2)=(yy-4.)*(yy-3.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/48.
+ poidy(3)=-(yy-4.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/120.
+ poidy(4)=(yy-3.)*(yy-2.)*(yy-1.)*yy*(yy+1.)*(yy+2.)/720.
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do d=-3,4
+ remaille(ivar,jp(d)+1)=remaille(ivar,jp(d)+1)+donne(i)*poidy(d)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_y
+
+
+
+ subroutine remaill_l2_x(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = int((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ if ((posx(i)-xg)<0) then
+ do c=0,5
+ ip(c)=ip(c)-1
+ end do
+ end if
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx !relatif
+
+ !conditions au bord
+ !------------------
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5) then
+ poidx(1)=0.5*xx1*(xx1-1.)
+ poidx(2)=1.-xx1**2
+ poidx(3)=0.5*xx1*(1.+xx1)
+ poidx(4)=0.
+ else
+ poidx(1)=0.
+ poidx(2)=0.5*(1.-xx1)*(2.-xx1)
+ poidx(3)=2.*xx1-xx1**2
+ poidx(4)=0.5*(xx1-1.)*xx1
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,4
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_x
+
+
+
+ subroutine remaill_l2_y(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = int((posy(i)-yb)/dy)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ if ((posy(i)-yb)<0) then
+ do c=0,5
+ ip(c)=ip(c)-1
+ end do
+ end if
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(2),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+
+ do c=0,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5) then
+ poidx(1)=0.5*xx1*(xx1-1.)
+ poidx(2)=1.-xx1**2
+ poidx(3)=0.5*xx1*(1.+xx1)
+ poidx(4)=0.
+ else
+ poidx(1)=0.
+ poidx(2)=0.5*(1.-xx1)*(2.-xx1)
+ poidx(3)=2.*xx1-xx1**2
+ poidx(4)=0.5*(xx1-1.)*xx1
+ end if
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,4
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_y
+
+
+ subroutine remaill_l5_x(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4,x5
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_x
+
+
+ subroutine remaill_l5_y(donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,tmp_pos,x2,x3,x4,x5
+
+ remaille=0.
+
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(2),kind=8)*dy-yb)/dy !relatif
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_y
+
+
+!!$ subroutine remaill_m6kernel_x (donne,posx,posy,remaille)
+!!$ implicit none
+!!$ real(kind=8),dimension(:),intent(in) :: donne
+!!$ real(kind=8),dimension(:),intent(in) :: posx,posy
+!!$ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+!!$ integer :: i,c,d,j,per
+!!$ integer,dimension(-3:3) :: ip
+!!$ real(kind=8),dimension(-3:3) :: xx
+!!$
+!!$
+!!$ remaille=0.
+!!$
+!!$ do i=1,npart
+!!$
+!!$ j=nint((posy(i)-yb)/dy)+1
+!!$
+!!$ !numero des points sur le maillage
+!!$ !--------------------------------
+!!$ ip(0) = floor((posx(i)-xg)/dx)
+!!$ ip(-1) = ip(0) - 1
+!!$ ip(-2) = ip(0) - 2
+!!$ ip(1) = ip(0) + 1
+!!$ ip(2) = ip(0) + 2
+!!$ ip(3) = ip(0) + 3
+!!$
+!!$
+!!$
+!!$ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+!!$ !----------------------------------------------------
+!!$ per=mod(i -partxun(j) +ndimx(j),ndimx(j)) + partxun(j)
+!!$ do c=-2,3
+!!$ xx(c) = (-posx(per) + real(ip(c),kind=8)*dx+xg)/dx
+!!$ end do
+!!$
+!!$ !conditions au bord
+!!$ !------------------
+!!$ !periodique:
+!!$ do c=-2,3
+!!$ ip(c)=mod(ip(c)+nx,nx)
+!!$ end do
+!!$
+!!$
+!!$ !remaillage à l'interrieur domaine
+!!$ !---------------------------------
+!!$ do c=-2,3
+!!$ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(xx(c))
+!!$ end do
+!!$
+!!$ end do
+!!$ contains
+!!$ function poids(x) result(p)
+!!$ implicit none
+!!$ real(kind=8) :: x
+!!$ real(kind=8) :: p
+!!$
+!!$ !mp4
+!!$ !if (abs(x)<=1.) p=1.-5.*x*x/2.+3.*abs(x)**3/2.
+!!$ !if ((abs(x)>1.).and.(abs(x)<=2.)) p=(2.-abs(x))**2*(1.-abs(x))/2.
+!!$ !if (abs(x)>=2.) p=0.
+!!$
+!!$ !lambda 3
+!!$ !if (abs(x)<=1.) p=(1.-x*x)*(2.-abs(x))/2.
+!!$ !if ((abs(x)>1.).and.(abs(x)<=2.)) p=(1.-abs(x))*(2.-abs(x))*(3.-abs(x))/6.
+!!$ !if (abs(x)>=2.) p=0.
+!!$
+!!$ !M6*
+!!$ !if (abs(x)<1.) p=-1./12.*(abs(x)-1.)*(24.*abs(x)**4+38.*abs(x)**3-3.*abs(x)**2+12.*abs(x)+12.)
+!!$ !if ((abs(x)>=1.).and.(abs(x)<2.)) p=1./24.*(abs(x)-1.)*(abs(x)-2.)*(25.*abs(x)**3-114.*abs(x)**2+153.*abs(x)-48.)
+!!$ !if ((abs(x)>=2.).and.(abs(x)<3.)) p=-1./24.*(abs(x)-2.)*(abs(x)-3.)**3*(5.*abs(x)-8.)
+!!$ !if (abs(x)>=3.) p=0.
+!!$
+!!$ !M6'''
+!!$ if (abs(x)<1.) p=-1./88.*(abs(x)-1.)*(60.*abs(x)**4-87.*abs(x)**3-87.*abs(x)**2+88.*abs(x)+88.)
+!!$ if ((abs(x)>=1.).and.(abs(x)<2.)) p=1./176.*(abs(x)-1.)*(abs(x)-2.)*(60.*abs(x)**3-261.*abs(x)**2+257.*abs(x)+68.)
+!!$ if ((abs(x)>=2.).and.(abs(x)<3.)) p=-3./176.*(abs(x)-2.)*(4.*abs(x)**2-17.*abs(x)+12.)*(abs(x)-3.)**2
+!!$ if (abs(x)>=3.) p=0.
+!!$
+!!$ end function poids
+!!$
+!!$ end subroutine remaill_m6kernel_x
+!!$
+!!$
+!!$
+!!$ subroutine remaill_m6kernel_y (donne,posx,posy,remaille)
+!!$ implicit none
+!!$ real(kind=8),dimension(:),intent(in) :: donne
+!!$ real(kind=8),dimension(:),intent(in) :: posx,posy
+!!$ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+!!$ integer :: i,c,d,ivar,per
+!!$ integer,dimension(-3:3) :: ip
+!!$ real(kind=8),dimension(-3:3) :: xx
+!!$
+!!$
+!!$ remaille=0.
+!!$
+!!$ do i=1,npart
+!!$
+!!$ ivar=nint((posx(i)-xg)/dx)+1
+!!$
+!!$ !numero des points sur le maillage
+!!$ !--------------------------------
+!!$ ip(0) = floor((posy(i)-yb)/dy)
+!!$ ip(-1) = ip(0) - 1
+!!$ ip(-2) = ip(0) - 2
+!!$ ip(1) = ip(0) + 1
+!!$ ip(2) = ip(0) + 2
+!!$ ip(3) = ip(0) + 3
+!!$
+!!$
+!!$
+!!$ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+!!$ !----------------------------------------------------
+!!$ per=mod(i -partyun(ivar) +ndimy(ivar),ndimy(ivar)) + partyun(ivar)
+!!$ do c=-2,3
+!!$ xx(c) = (-posy(per) + real(ip(c),kind=8)*dy+yb)/dy
+!!$ end do
+!!$
+!!$ !conditions au bord
+!!$ !------------------
+!!$ do c=-2,3
+!!$ ip(c)=mod(ip(c)+ny,ny)
+!!$ end do
+!!$
+!!$
+!!$ !remaillage à l'interrieur domaine
+!!$ !---------------------------------
+!!$ do c=-2,3
+!!$ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(xx(c))
+!!$ end do
+!!$
+!!$ end do
+!!$ contains
+!!$ function poids(x) result(p)
+!!$ implicit none
+!!$ real(kind=8) :: x
+!!$ real(kind=8) :: p
+!!$
+!!$ !mp4
+!!$ !if (abs(x)<=1.) p=1.-5.*x*x/2.+3.*abs(x)**3/2.
+!!$ !if ((abs(x)>1.).and.(abs(x)<=2.)) p=(2.-abs(x))**2*(1.-abs(x))/2.
+!!$ !if (abs(x)>=2.) p=0.
+!!$
+!!$ !lambda 3
+!!$ !if (abs(x)<=1.) p=(1.-x*x)*(2.-abs(x))/2.
+!!$ !if ((abs(x)>1.).and.(abs(x)<=2.)) p=(1.-abs(x))*(2.-abs(x))*(3.-abs(x))/6.
+!!$ !if (abs(x)>=2.) p=0.
+!!$
+!!$ !M6*
+!!$ !if (abs(x)<1.) p=-1./12.*(abs(x)-1.)*(24.*abs(x)**4+38.*abs(x)**3-3.*abs(x)**2+12.*abs(x)+12.)
+!!$ !if ((abs(x)>=1.).and.(abs(x)<2.)) p=1./24.*(abs(x)-1.)*(abs(x)-2.)*(25.*abs(x)**3-114.*abs(x)**2+153.*abs(x)-48.)
+!!$ !if ((abs(x)>=2.).and.(abs(x)<3.)) p=-1./24.*(abs(x)-2.)*(abs(x)-3.)**3*(5.*abs(x)-8.)
+!!$ !if (abs(x)>=3.) p=0.
+!!$
+!!$ !M6'''
+!!$ if (abs(x)<1.) p=-1./88.*(abs(x)-1.)*(60.*abs(x)**4-87.*abs(x)**3-87.*abs(x)**2+88.*abs(x)+88.)
+!!$ if ((abs(x)>=1.).and.(abs(x)<2.)) p=1./176.*(abs(x)-1.)*(abs(x)-2.)*(60.*abs(x)**3-261.*abs(x)**2+257.*abs(x)+68.)
+!!$ if ((abs(x)>=2.).and.(abs(x)<3.)) p=-3./176.*(abs(x)-2.)*(4.*abs(x)**2-17.*abs(x)+12.)*(abs(x)-3.)**2
+!!$ if (abs(x)>=3.) p=0.
+!!$
+!!$ end function poids
+!!$
+!!$ end subroutine remaill_m6kernel_y
+
+
+
+
+
+
+
+
+
+
+
+
+ subroutine remaill_l2_bloc_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ case(2)
+ poids(0)=1.-0.5*xx*(1.+xx)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ case(4)
+ poids(-2)=0.5*xx*(1.+xx)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ case(5)
+ poids(-1)=-0.5*xx+0.5*xx**2
+ poids(0)=1.-poids(-1)
+
+ end select
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=0.5*xx*(1.+xx)
+ else
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ end if
+ case(1)
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1)
+ case(3)
+ poids(1)=3.*0.5*xx-0.5*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_x
+
+
+ subroutine remaill_l2_bloc_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ case(2)
+ poids(0)=1.-0.5*xx*(1.+xx)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ case(4)
+ poids(-2)=0.5*xx*(1.+xx)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ case(5)
+ poids(-1)=-0.5*xx+0.5*xx**2
+ poids(0)=1.-poids(-1)
+
+ end select
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=0.5*xx*(1.+xx)
+ else
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ end if
+ case(1)
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1)
+ case(3)
+ poids(1)=3.*0.5*xx-0.5*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_y
+
+
+ subroutine remaill_l4_bloc_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+ else
+ t1=(xx-1.)*(xx-2.)*(xx-3.)
+ poids(-1)=t1*xx/24.
+ poids(0)=-t1*(xx+1.)/6.
+ end if
+ case(1)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+
+ case(2)
+ t1=(xx-1.)*(xx-2.)/12.
+ poids(-1)=t1*xx*(xx-3)/2.
+ poids(0)=t1*(xx+6.)*(xx+1.)
+ case(3)
+ t1=0.5*(xx-1.)*(xx-2.)
+ poids(-2)=t1*xx/12.*(xx+1.)
+ poids(-1)=-t1*xx/3.*(xx+2.)
+ poids(0)=t1*(xx+1.)
+ case(4)
+ t2=(xx**2-1.)
+ t1=xx*(xx+2.)*0.5
+ poids(-3)=t2*t1/12.
+ poids(-2)=-t2*xx/6.*(xx+3.)
+ poids(-1)=t1*(xx-1.)
+ poids(0)=t2*(xx**2-4.)/4.
+ case(5)
+ t1=(xx-2.)*(xx-1.)/4.
+ poids(-1)=-t1*xx/6.*(3*xx+7.)
+ poids(0)=t1*(xx+2.)*(xx+1.)
+ case(6)
+ t1= (xx-1.)*(xx-2.)/6.
+ t2=t1*(xx+1.)
+ poids(-2)=t2*xx/4.
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.)
+ case(7)
+ t1=(xx-1.)*(xx+2.)
+ t2=xx*(xx+1)/6.
+ poids(-3)=t1*t2/4.
+ poids(-2)=-t2*(xx-1.)
+ poids(-1)=-xx*t1/6.*(xx-2.)
+ poids(0)=t1*(xx-2.)/4.*(xx+1.)
+ case(8)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=(xx-6.)*(xx+2.)*(xx**2-1.)/12.
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ else
+ t1=xx*(xx+1.)*(xx-3.)
+ poids(1)=t1*(xx-2.)/4.
+ poids(2)=-t1*(xx-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ end if
+ case(1)
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ case(2)
+ t1=xx*(xx+1.)*0.5
+ t2=t1*(xx-1.)
+ poids(1)=-t1*(xx-2.)
+ poids(2)=-t2/3.*(xx-3.)
+ poids(3)=t2*(xx-2.)/12.
+ case(3)
+ t1=xx*(xx+1.)/12.
+ poids(1)=t1*(xx-2.)*(xx-7.)
+ poids(2)=t1*(xx+2.)*(xx-1.)/2.
+ case(4)
+ t1=xx*(xx+1.)
+ t2=t1*(xx-1.)/6.
+ poids(1)=-t1*(xx+2.)*(xx-2.)/6.
+ poids(2)=t2
+ poids(3)=t2*(xx-2.)/4.
+ case(5)
+ poids(1)=-xx/24.*(3.*xx-7.)*(xx+2.)*(xx+1.)
+ case(6)
+ t1=xx*(xx+1.)/4.
+ poids(1)=t1*(xx-3.)*(xx-2.)
+ poids(2)=-t1*(3.*xx-10.)*(xx-1.)/6.
+ case(7)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_x
+
+
+ subroutine remaill_l4_bloc_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+ else
+ t1=(xx-1.)*(xx-2.)*(xx-3.)
+ poids(-1)=t1*xx/24.
+ poids(0)=-t1*(xx+1.)/6.
+ end if
+ case(1)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+
+ case(2)
+ t1=(xx-1.)*(xx-2.)/12.
+ poids(-1)=t1*xx*(xx-3)/2.
+ poids(0)=t1*(xx+6.)*(xx+1.)
+ case(3)
+ t1=0.5*(xx-1.)*(xx-2.)
+ poids(-2)=t1*xx/12.*(xx+1.)
+ poids(-1)=-t1*xx/3.*(xx+2.)
+ poids(0)=t1*(xx+1.)
+ case(4)
+ t2=(xx**2-1.)
+ t1=xx*(xx+2.)*0.5
+ poids(-3)=t2*t1/12.
+ poids(-2)=-t2*xx/6.*(xx+3.)
+ poids(-1)=t1*(xx-1.)
+ poids(0)=t2*(xx**2-4.)/4.
+ case(5)
+ t1=(xx-2.)*(xx-1.)/4.
+ poids(-1)=-t1*xx/6.*(3*xx+7.)
+ poids(0)=t1*(xx+2.)*(xx+1.)
+ case(6)
+ t1= (xx-1.)*(xx-2.)/6.
+ t2=t1*(xx+1.)
+ poids(-2)=t2*xx/4.
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.)
+ case(7)
+ t1=(xx-1.)*(xx+2.)
+ t2=xx*(xx+1)/6.
+ poids(-3)=t1*t2/4.
+ poids(-2)=-t2*(xx-1.)
+ poids(-1)=-xx*t1/6.*(xx-2.)
+ poids(0)=t1*(xx-2.)/4.*(xx+1.)
+ case(8)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=(xx-6.)*(xx+2.)*(xx**2-1.)/12.
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ else
+ t1=xx*(xx+1.)*(xx-3.)
+ poids(1)=t1*(xx-2.)/4.
+ poids(2)=-t1*(xx-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ end if
+ case(1)
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ case(2)
+ t1=xx*(xx+1.)*0.5
+ t2=t1*(xx-1.)
+ poids(1)=-t1*(xx-2.)
+ poids(2)=-t2/3.*(xx-3.)
+ poids(3)=t2*(xx-2.)/12.
+ case(3)
+ t1=xx*(xx+1.)/12.
+ poids(1)=t1*(xx-2.)*(xx-7.)
+ poids(2)=t1*(xx+2.)*(xx-1.)/2.
+ case(4)
+ t1=xx*(xx+1.)
+ t2=t1*(xx-1.)/6.
+ poids(1)=-t1*(xx+2.)*(xx-2.)/6.
+ poids(2)=t2
+ poids(3)=t2*(xx-2.)/4.
+ case(5)
+ poids(1)=-xx/24.*(3.*xx-7.)*(xx+2.)*(xx+1.)
+ case(6)
+ t1=xx*(xx+1.)/4.
+ poids(1)=t1*(xx-3.)*(xx-2.)
+ poids(2)=-t1*(3.*xx-10.)*(xx-1.)/6.
+ case(7)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_y
+
+
+
+
+
+
+
+
+
+ subroutine remaill_l2_bloc_v2_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.) !alpha
+ poids(0)=1.-xx**2 !beta
+ poids(1)=0.5*xx*(1.+xx) !gamma
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx) !alpha'
+ poids(1)=2.*xx-xx**2 !beta'
+ poids(2)=0.5*(xx-1.)*xx !gamma'
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ poids(1)=1.-poids(0)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-poids(-1)
+ case(4)
+ poids(0)=-0.5*xx*(xx+1.)+1.
+ poids(1)=1.-poids(0)
+ case(5)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1.)
+ case(6)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ case(7)
+ poids(-2)=0.5*xx*(xx+1)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ end select
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_v2_x
+
+ subroutine remaill_l2_bloc_v2_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.) !alpha
+ poids(0)=1.-xx**2 !beta
+ poids(1)=0.5*xx*(1.+xx) !gamma
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx) !alpha'
+ poids(1)=2.*xx-xx**2 !beta'
+ poids(2)=0.5*(xx-1.)*xx !gamma'
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ poids(1)=1.-poids(0)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-poids(-1)
+ case(4)
+ poids(0)=-0.5*xx*(xx+1.)+1.
+ poids(1)=1.-poids(0)
+ case(5)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1.)
+ case(6)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ case(7)
+ poids(-2)=0.5*xx*(xx+1)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_v2_y
+
+
+ subroutine remaill_l4_bloc_v2_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+ select case (blocg(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx**4/12.-2.*xx**3/3.+5.*xx**2/12.+7.*xx/6.
+ case(3)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=1.+xx**4/12.-13.*xx**2/12.-xx**3/3.+xx/3.
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=xx*(xx-1.)*(xx-2.)*(xx-3.)/24.
+ poids(0)=xx**4/12.+xx**3/3.-13.*xx**2/12.-xx/3.+1.
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=1.-xx**4/8.+7.*xx**3/12.-3.*xx**2/8.-13.*xx/12.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=-xx**4/8.+xx**3/12.+5.*xx**2/8.-7.*xx/12.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(7)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=0.5*xx**3-xx**2-0.5*xx+1.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(8)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=-xx*(xx+3.)*(xx**2-1.)/6.
+ poids(-1)=0.5*xx**3+0.5*xx**2-xx
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(9)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx**3/6.+0.5*xx**2-xx/3.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(10)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=xx*(1.-xx**2)/6.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=-xx**4/8.+5.*xx**3/12.+xx**2/8.-5.*xx/12.
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=-xx**4/8.-xx**3/12.+5.*xx**2/8.+7.*xx/12.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=xx*(xx+2.)*(xx**2-1.)/24.
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6.
+ poids(3)=xx**3/6.-0.5*xx*2+xx/3.
+ poids(4)=xx*(xx-1)*(xx-2.)*(xx-3.)/24.
+ case(7)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6.
+ poids(2)=xx*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ case(8)
+ poids(1)=-0.5*xx**3+0.5*xx**2+xx
+ poids(2)=-xx*(xx-3)*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ end select
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_v2_x
+
+
+
+
+ subroutine remaill_l4_bloc_v2_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+ select case (blocg(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx**4/12.-2.*xx**3/3.+5.*xx**2/12.+7.*xx/6.
+ case(3)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=1.+xx**4/12.-13.*xx**2/12.-xx**3/3.+xx/3.
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=xx*(xx-1.)*(xx-2.)*(xx-3.)/24.
+ poids(0)=xx**4/12.+xx**3/3.-13.*xx**2/12.-xx/3.+1.
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=1.-xx**4/8.+7.*xx**3/12.-3.*xx**2/8.-13.*xx/12.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=-xx**4/8.+xx**3/12.+5.*xx**2/8.-7.*xx/12.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(7)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=0.5*xx**3-xx**2-0.5*xx+1.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(8)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=-xx*(xx+3.)*(xx**2-1.)/6.
+ poids(-1)=0.5*xx**3+0.5*xx**2-xx
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(9)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx**3/6.+0.5*xx**2-xx/3.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(10)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=xx*(1.-xx**2)/6.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=-xx**4/8.+5.*xx**3/12.+xx**2/8.-5.*xx/12.
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=-xx**4/8.-xx**3/12.+5.*xx**2/8.+7.*xx/12.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=xx*(xx+2.)*(xx**2-1.)/24.
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6.
+ poids(3)=xx**3/6.-0.5*xx*2+xx/3.
+ poids(4)=xx*(xx-1)*(xx-2.)*(xx-3.)/24.
+ case(7)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6.
+ poids(2)=xx*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ case(8)
+ poids(1)=-0.5*xx**3+0.5*xx**2+xx
+ poids(2)=-xx*(xx-3)*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ end select
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_v2_y
+
+
+
+ subroutine remaill_l2_bloc_v2_limit_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2) :: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1) :: phi
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+ else
+
+ poids(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poids(1)=cb(xx-1.,1,1)
+ poids(2)=cc(xx-1.,1)
+ else
+ poids(1)=cb(xx-1.,1,0)
+ poids(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+ case(1)
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+
+ case(2)
+ poids(0)=ca(xx-1.,1)
+ poids(1)=cb(xx-1.,1,0)+cc(xx-1.,0)
+ case(3)
+ poids(-1)=ca(xx,0)
+ poids(0)=cb(xx,0)+cc(xx,0)
+ case(4)
+ poids(0)=ca(xx,1)+cb(xx,1,0)
+ poids(1)=cc(xx,0)
+
+
+
+ case(5)
+ poids(-1)=ca(xx,0)
+ poids(0)=cb(xx,0)
+ poids(1)=cc(xx,0)-cc(xx-1.,1)
+ poids(2)=cc(xx-1.,1)
+
+ case(6)
+ poids(-1)=ca(xx,0)
+ poids(0)=ca(xx-1.,1)-ca(xx,0)
+ poids(1)=cb(xx-1.,1)
+ poids(2)=cc(xx-1.,1)
+
+
+ case(7)
+ poids(-2)=ca(xx+1.,0)
+ poids(-1)=ca(xx,0)-ca(xx+1.,0)
+ poids(0)=cb(xx,0)
+ poids(1)=cc(xx,0)
+ end select
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8. ! +1./6.
+ case(0)
+ c=-x**2+1. -2./8. !-2./6.
+ case(1)
+ c=0.5*x*(1.+x) +1./8. ! +1./6.
+ end select
+
+ end function coeff_tscg
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posx(mod(ipart-1+vois+npart,npart)+1) - real( floor((posx(mod(ipart-1+vois+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+
+
+ end subroutine remaill_l2_bloc_v2_limit_x
+
+ subroutine remaill_l2_bloc_v2_limit_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2):: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1):: phi
+
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+ else
+
+ poids(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poids(1)=cb(xx-1.,1,1)
+ poids(2)=cc(xx-1.,1)
+ else
+ poids(1)=cb(xx-1.,1,0)
+ poids(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+ case(1)
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+
+ case(2)
+ poids(0)=ca(xx-1.,1)
+ poids(1)=cb(xx-1.,1,0)+cc(xx-1.,0)
+ case(3)
+ poids(-1)=ca(xx,0)
+ poids(0)=cb(xx,0)+cc(xx,0)
+ case(4)
+ poids(0)=ca(xx,1)+cb(xx,1,0)
+ poids(1)=cc(xx,0)
+
+
+
+ case(5)
+ poids(-1)=ca(xx,0)
+ poids(0)=cb(xx,0)
+ poids(1)=cc(xx,0)-cc(xx-1.,1)
+ poids(2)=cc(xx-1.,1)
+
+ case(6)
+ poids(-1)=ca(xx,0)
+ poids(0)=ca(xx-1.,1)-ca(xx,0)
+ poids(1)=cb(xx-1.,1)
+ poids(2)=cc(xx-1.,1)
+
+
+ case(7)
+ poids(-2)=ca(xx+1.,0)
+ poids(-1)=ca(xx,0)-ca(xx+1.,0)
+ poids(0)=cb(xx,0)
+ poids(1)=cc(xx,0)
+ end select
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8. ! +1./6.
+ case(0)
+ c=-x**2+1. -2./8. !-2./6.
+ case(1)
+ c=0.5*x*(1.+x) +1./8. ! +1./6.
+ end select
+
+ end function coeff_tscg
+
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posy(mod(ipart-1+vois+npart,npart)+1) - real( floor((posy(mod(ipart-1+vois+npart,npart)+1)-yb)/dy) ,kind=8)*dy-yb)/dy
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+ end subroutine remaill_l2_bloc_v2_limit_y
+
+
+ subroutine remaill_l2_limit_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2) :: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1) :: phi
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+ if (xx<=0.5) then
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+ else
+
+ poids(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poids(1)=cb(xx-1.,1,1)
+ poids(2)=cc(xx-1.,1)
+ else
+ poids(1)=cb(xx-1.,1,0)
+ poids(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8. ! +1./6.
+ case(0)
+ c=-x**2+1. -2./8. !-2./6.
+ case(1)
+ c=0.5*x*(1.+x) +1./8. ! +1./6.
+ end select
+
+ end function coeff_tscg
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posx(mod(ipart-1+vois+npart,npart)+1) - real( floor((posx(mod(ipart-1+vois+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+
+
+ end subroutine remaill_l2_limit_x
+
+ subroutine remaill_l2_limit_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2):: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1):: phi
+
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+
+ if (xx<=0.5) then
+
+ poids(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poids(0)=cb(xx,0,1)
+ poids(1)=cc(xx,1)
+ else
+ poids(0)=cb(xx,0,0)
+ poids(1)=cc(xx,0)
+ end if
+
+ else
+
+ poids(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poids(1)=cb(xx-1.,1,1)
+ poids(2)=cc(xx-1.,1)
+ else
+ poids(1)=cb(xx-1.,1,0)
+ poids(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8. ! +1./6.
+ case(0)
+ c=-x**2+1. -2./8. !-2./6.
+ case(1)
+ c=0.5*x*(1.+x) +1./8. ! +1./6.
+ end select
+
+ end function coeff_tscg
+
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posy(mod(ipart-1+vois+npart,npart)+1) - real( floor((posy(mod(ipart-1+vois+npart,npart)+1)-yb)/dy) ,kind=8)*dy-yb)/dy
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+ end subroutine remaill_l2_limit_y
+
+
+
+
+
+ subroutine remaill_l4_bloc_v2_limit_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+ real(kind=8) :: phi_m3demi,phi_mdemi,phi_pdemi,phi_p3demi
+ real(kind=8),dimension(-1:2) :: phi
+
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ call calcul_phi_minmax(phi)
+ phi_m3demi=phi(-1)
+ phi_mdemi=phi(0)
+ phi_pdemi=phi(1)
+ phi_p3demi=phi(2)
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1.)+cd(xx-1.)+ce(xx-1.)-ce(xx)
+ case(3)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)+cd(xx)+ce(xx)-ce(xx+1.)
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=ca(xx)-ca(xx-1.)+cb(xx)+cc(xx)
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=ca(xx-1.)+cb(xx-1.)
+ poids(1)=cc(xx-1.)
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx)+cb(xx)
+ poids(0)=cc(xx)
+ case(7)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=ca(xx-1.)-ca(xx)+cb(xx-1.)-cb(xx)
+ poids(1)=cc(xx-1)
+ case(8)
+ poids(-3)=ca(xx+1.)
+ poids(-2)=cb(xx+1.)
+ poids(-1)=ca(xx)-ca(xx+1.)+cb(xx)-cb(xx+1.)
+ poids(0)=cc(xx)
+ case(9)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=ca(xx-1.)-ca(xx)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ case(10)
+ poids(-3)=ca(xx+1.)
+ poids(-2)=ca(xx)-ca(xx+1.)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=cd(xx-1.)+ce(xx-1.)
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=cd(xx)+ce(xx)
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=ce(xx+1.)
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)-ce(xx-2.)
+ poids(4)=ce(xx-2.)
+ case(7)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)-ce(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ case(8)
+ poids(1)=cd(xx)-cd(xx-1.)+ce(xx)-ce(xx-1.)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ contains
+
+ function ca(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ca
+ !ca=x*(x-1.)*(x-2.)*(x+1.)/24.
+ ca=coeff_M5g(-2,x)+phi_m3demi*coeff_l4mM5g(-2,x)
+ end function ca
+ function cb(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cb
+ !cb=-x*(x-1.)*(x**2-4.)/6.
+ cb=coeff_M5g(-1,x)-phi_m3demi*coeff_l4mM5g(-2,x)+phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))
+ end function cb
+ function cc(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cc
+ !cc=(x**2-4.)*(x**2-1.)/4.
+ cc=coeff_M5g(0,x)-phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))-phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))
+ end function cc
+ function cd(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cd
+ !cd=-x*(x+1.)*(x+2.)*(x-2.)/6.
+ cd=coeff_M5g(1,x)+phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))-phi_p3demi*coeff_l4mM5g(2,x)
+ end function cd
+ function ce(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ce
+ !ce=x*(x+1.)*(x+2.)*(x-1.)/24.
+ ce=coeff_M5g(2,x)+phi_p3demi*coeff_l4mM5g(2,x)
+ end function ce
+
+
+ function coeff_l4g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=x*(x-1)*(x-2)*(x+1)/24.
+ case(-1)
+ c=-x*(x-1)*(x-2)*(x+2)/6.
+ case(0)
+ c=(x-2)*(x-1)*(x+1)*(x+2)/4.
+ case(1)
+ c=-x*(x-2)*(x+1)*(x+2)/6.
+ case(2)
+ c=x*(x-1)*(x+1)*(x+2)/24.
+ end select
+
+ end function coeff_l4g
+
+ function coeff_M5g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=(2.*x-1.)**4/384.
+ case(-1)
+ c=19./96.-11/24.*x+x**2/4.+x**3/6.-x**4/6.
+ case(0)
+ c=115./192.-5./8.*x**2+x**4/4.
+ case(1)
+ c=19./96.+11/24.*x-x**3/6.+x**2/4.-x**4/6.
+ case(2)
+ c=(2.*x+1.)**4/384.
+ end select
+
+ end function coeff_M5g
+
+ function coeff_l4mM5g (num,x) result(c)
+ !lambda4 - M5 gauche
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=5.*x/48.*(1.-x)-1./384.
+ case(-1)
+ c=-5.*x/24.*(1.-2.*x)-19/96.
+ case(0)
+ c=-5.*x**2/8.+77./192.
+ case(1)
+ c=5.*x/24.*(1.+2.*x)-19./96.
+ case(2)
+ c=-5.*x/48.*(1.+x)-1./384.
+ end select
+
+ end function coeff_l4mM5g
+
+
+
+
+ subroutine calcul_phi_minmax(phi_out)
+ implicit none
+ real(kind=8),dimension(-1:2),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u,bmin,bmax,x,xx_vois
+ real(kind=8),dimension(-5:5,-5:5) :: ej,fj
+ real(kind=8) :: tp1,tp2,phi1,phi2
+ integer :: ib,jb
+
+
+ !particules voisines
+ !-------------------
+ do ib=-4,5
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ !coeff decentre droite = coeff decentre gauche -1
+ !-------------------------------------------------
+ do ib=-4,3
+ xx_vois(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+
+ if ((xx_vois(ib)>0.5).and.((blocg(mod(i-1+ib+npart,npart)+1)==0).or.(blocd(mod(i-1+ib+npart,npart)+1)==0))) then
+ x(ib)=xx_vois(ib)-1.
+ else
+ x(ib)=xx_vois(ib)
+ end if
+ end do
+
+
+ do ib=-4,3
+
+ bmin(ib)=min(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+ bmax(ib)=max(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+
+
+ do jb=-4,3
+ ej(ib,jb)=coeff_M5g(-2,x(jb))*u(ib+2)+coeff_M5g(-1,x(jb))*u(ib+1)+coeff_M5g(0,x(jb))*u(ib)+coeff_M5g(1,x(jb))*u(ib-1)+coeff_M5g(2,x(jb))*u(ib-2)
+ fj(ib,jb)=coeff_l4mM5g(-2,x(jb))*u(ib+1)+(coeff_l4mM5g(-2,x(jb))+coeff_l4mM5g(-1,x(jb)))*u(ib)-(coeff_l4mM5g(1,x(jb))+coeff_l4mM5g(2,x(jb)))*u(ib-1)-coeff_l4mM5g(2,x(jb))*u(ib-2)
+ end do
+
+ end do
+
+
+ do ib=-1,2
+
+ tp1=(bmin(ib-1)-ej(ib-1,ib)+max(0.,fj(ib-1,ib)))/fj(ib,ib)
+ tp2=(bmax(ib-1)-ej(ib-1,ib)+min(0.,fj(ib-1,ib)))/fj(ib,ib)
+ !phi1=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi1=max(0.,min(1.,max(tp1,tp2)))
+
+ tp1=(bmin(ib)-ej(ib,ib-1)+max(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ tp2=(bmax(ib)-ej(ib,ib-1)+min(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ !phi2=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi2=max(0.,min(1.,max(tp1,tp2)))
+
+ phi_out(ib)=min(phi1,phi2)
+
+ if(abs(fj(ib,ib))<0.0000001) phi_out(ib)=0.
+ if(abs(fj(ib,ib-1))<0.0000001) phi_out(ib)=0.
+
+ end do
+
+
+ end subroutine calcul_phi_minmax
+
+
+ end subroutine remaill_l4_bloc_v2_limit_x
+
+
+
+
+ subroutine remaill_l4_bloc_v2_limit_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+ real(kind=8) :: phi_m3demi,phi_mdemi,phi_pdemi,phi_p3demi
+ real(kind=8),dimension(-1:2) :: phi
+
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+ call calcul_phi_minmax(phi)
+ phi_m3demi=phi(-1)
+ phi_mdemi=phi(0)
+ phi_pdemi=phi(1)
+ phi_p3demi=phi(2)
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1.)+cd(xx-1.)+ce(xx-1.)-ce(xx)
+ case(3)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)+cd(xx)+ce(xx)-ce(xx+1.)
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=ca(xx)-ca(xx-1.)+cb(xx)+cc(xx)
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=ca(xx-1.)+cb(xx-1.)
+ poids(1)=cc(xx-1.)
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx)+cb(xx)
+ poids(0)=cc(xx)
+ case(7)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=ca(xx-1.)-ca(xx)+cb(xx-1.)-cb(xx)
+ poids(1)=cc(xx-1)
+ case(8)
+ poids(-3)=ca(xx+1.)
+ poids(-2)=cb(xx+1.)
+ poids(-1)=ca(xx)-ca(xx+1.)+cb(xx)-cb(xx+1.)
+ poids(0)=cc(xx)
+ case(9)
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=ca(xx-1.)-ca(xx)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ case(10)
+ poids(-3)=ca(xx+1.)
+ poids(-2)=ca(xx)-ca(xx+1.)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=cd(xx-1.)+ce(xx-1.)
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=cd(xx)+ce(xx)
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=ce(xx+1.)
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)-ce(xx-2.)
+ poids(4)=ce(xx-2.)
+ case(7)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)-ce(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ case(8)
+ poids(1)=cd(xx)-cd(xx-1.)+ce(xx)-ce(xx-1.)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+
+
+ end select
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+ contains
+
+ function ca(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ca
+ !ca=x*(x-1.)*(x-2.)*(x+1.)/24.
+ ca=coeff_M5g(-2,x)+phi_m3demi*coeff_l4mM5g(-2,x)
+ end function ca
+ function cb(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cb
+ !cb=-x*(x-1.)*(x**2-4.)/6.
+ cb=coeff_M5g(-1,x)-phi_m3demi*coeff_l4mM5g(-2,x)+phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))
+ end function cb
+ function cc(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cc
+ !cc=(x**2-4.)*(x**2-1.)/4.
+ cc=coeff_M5g(0,x)-phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))-phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))
+ end function cc
+ function cd(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cd
+ !cd=-x*(x+1.)*(x+2.)*(x-2.)/6.
+ cd=coeff_M5g(1,x)+phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))-phi_p3demi*coeff_l4mM5g(2,x)
+ end function cd
+ function ce(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ce
+ !ce=x*(x+1.)*(x+2.)*(x-1.)/24.
+ ce=coeff_M5g(2,x)+phi_p3demi*coeff_l4mM5g(2,x)
+ end function ce
+
+
+ function coeff_l4g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=x*(x-1)*(x-2)*(x+1)/24.
+ case(-1)
+ c=-x*(x-1)*(x-2)*(x+2)/6.
+ case(0)
+ c=(x-2)*(x-1)*(x+1)*(x+2)/4.
+ case(1)
+ c=-x*(x-2)*(x+1)*(x+2)/6.
+ case(2)
+ c=x*(x-1)*(x+1)*(x+2)/24.
+ end select
+
+ end function coeff_l4g
+
+ function coeff_M5g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=(2.*x-1.)**4/384.
+ case(-1)
+ c=19./96.-11/24.*x+x**2/4.+x**3/6.-x**4/6.
+ case(0)
+ c=115./192.-5./8.*x**2+x**4/4.
+ case(1)
+ c=19./96.+11/24.*x-x**3/6.+x**2/4.-x**4/6.
+ case(2)
+ c=(2.*x+1.)**4/384.
+ end select
+
+ end function coeff_M5g
+
+ function coeff_l4mM5g (num,x) result(c)
+ !lambda4 - M5 gauche
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=5.*x/48.*(1.-x)-1./384.
+ case(-1)
+ c=-5.*x/24.*(1.-2.*x)-19/96.
+ case(0)
+ c=-5.*x**2/8.+77./192.
+ case(1)
+ c=5.*x/24.*(1.+2.*x)-19./96.
+ case(2)
+ c=-5.*x/48.*(1.+x)-1./384.
+ end select
+
+ end function coeff_l4mM5g
+
+
+
+
+ subroutine calcul_phi_minmax(phi_out)
+ implicit none
+ real(kind=8),dimension(-1:2),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u,bmin,bmax,x,xx_vois
+ real(kind=8),dimension(-5:5,-5:5) :: ej,fj
+ real(kind=8) :: tp1,tp2,phi1,phi2
+ integer :: ib,jb
+
+
+ !particules voisines
+ !-------------------
+ do ib=-4,5
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ !coeff decentre droite = coeff decentre gauche -1
+ !-------------------------------------------------
+ do ib=-4,3
+ xx_vois(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+
+ if ((xx_vois(ib)>0.5).and.((blocg(mod(i-1+ib+npart,npart)+1)==0).or.(blocd(mod(i-1+ib+npart,npart)+1)==0))) then
+ x(ib)=xx_vois(ib)-1.
+ else
+ x(ib)=xx_vois(ib)
+ end if
+ end do
+
+
+ do ib=-4,3
+
+ bmin(ib)=min(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+ bmax(ib)=max(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+
+
+ do jb=-4,3
+ ej(ib,jb)=coeff_M5g(-2,x(jb))*u(ib+2)+coeff_M5g(-1,x(jb))*u(ib+1)+coeff_M5g(0,x(jb))*u(ib)+coeff_M5g(1,x(jb))*u(ib-1)+coeff_M5g(2,x(jb))*u(ib-2)
+ fj(ib,jb)=coeff_l4mM5g(-2,x(jb))*u(ib+1)+(coeff_l4mM5g(-2,x(jb))+coeff_l4mM5g(-1,x(jb)))*u(ib)-(coeff_l4mM5g(1,x(jb))+coeff_l4mM5g(2,x(jb)))*u(ib-1)-coeff_l4mM5g(2,x(jb))*u(ib-2)
+ end do
+
+ end do
+
+
+ do ib=-1,2
+
+ tp1=(bmin(ib-1)-ej(ib-1,ib)+max(0.,fj(ib-1,ib)))/fj(ib,ib)
+ tp2=(bmax(ib-1)-ej(ib-1,ib)+min(0.,fj(ib-1,ib)))/fj(ib,ib)
+ !phi1=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi1=max(0.,min(1.,max(tp1,tp2)))
+
+ tp1=(bmin(ib)-ej(ib,ib-1)+max(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ tp2=(bmax(ib)-ej(ib,ib-1)+min(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ !phi2=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi2=max(0.,min(1.,max(tp1,tp2)))
+
+ phi_out(ib)=min(phi1,phi2)
+
+ if(abs(fj(ib,ib))<0.0000001) phi_out(ib)=0.
+ if(abs(fj(ib,ib-1))<0.0000001) phi_out(ib)=0.
+
+ end do
+
+
+ end subroutine calcul_phi_minmax
+
+ end subroutine remaill_l4_bloc_v2_limit_y
+
+
+
+
+ subroutine remaill_l4_limit_x (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+ real(kind=8) :: phi_m3demi,phi_mdemi,phi_pdemi,phi_p3demi
+ real(kind=8),dimension(-1:2) :: phi
+
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ call calcul_phi_minmax(phi)
+ phi_m3demi=phi(-1)
+ phi_mdemi=phi(0)
+ phi_pdemi=phi(1)
+ phi_p3demi=phi(2)
+
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,j)=remaille(ip(c)+1,j)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ contains
+
+ function ca(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ca
+ !ca=x*(x-1.)*(x-2.)*(x+1.)/24.
+ ca=coeff_M5g(-2,x)+phi_m3demi*coeff_l4mM5g(-2,x)
+ end function ca
+ function cb(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cb
+ !cb=-x*(x-1.)*(x**2-4.)/6.
+ cb=coeff_M5g(-1,x)-phi_m3demi*coeff_l4mM5g(-2,x)+phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))
+ end function cb
+ function cc(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cc
+ !cc=(x**2-4.)*(x**2-1.)/4.
+ cc=coeff_M5g(0,x)-phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))-phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))
+ end function cc
+ function cd(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cd
+ !cd=-x*(x+1.)*(x+2.)*(x-2.)/6.
+ cd=coeff_M5g(1,x)+phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))-phi_p3demi*coeff_l4mM5g(2,x)
+ end function cd
+ function ce(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ce
+ !ce=x*(x+1.)*(x+2.)*(x-1.)/24.
+ ce=coeff_M5g(2,x)+phi_p3demi*coeff_l4mM5g(2,x)
+ end function ce
+
+
+ function coeff_l4g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=x*(x-1)*(x-2)*(x+1)/24.
+ case(-1)
+ c=-x*(x-1)*(x-2)*(x+2)/6.
+ case(0)
+ c=(x-2)*(x-1)*(x+1)*(x+2)/4.
+ case(1)
+ c=-x*(x-2)*(x+1)*(x+2)/6.
+ case(2)
+ c=x*(x-1)*(x+1)*(x+2)/24.
+ end select
+
+ end function coeff_l4g
+
+ function coeff_M5g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=(2.*x-1.)**4/384.
+ case(-1)
+ c=19./96.-11/24.*x+x**2/4.+x**3/6.-x**4/6.
+ case(0)
+ c=115./192.-5./8.*x**2+x**4/4.
+ case(1)
+ c=19./96.+11/24.*x-x**3/6.+x**2/4.-x**4/6.
+ case(2)
+ c=(2.*x+1.)**4/384.
+ end select
+
+ end function coeff_M5g
+
+ function coeff_l4mM5g (num,x) result(c)
+ !lambda4 - M5 gauche
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=5.*x/48.*(1.-x)-1./384.
+ case(-1)
+ c=-5.*x/24.*(1.-2.*x)-19/96.
+ case(0)
+ c=-5.*x**2/8.+77./192.
+ case(1)
+ c=5.*x/24.*(1.+2.*x)-19./96.
+ case(2)
+ c=-5.*x/48.*(1.+x)-1./384.
+ end select
+
+ end function coeff_l4mM5g
+
+
+
+
+ subroutine calcul_phi_minmax(phi_out)
+ implicit none
+ real(kind=8),dimension(-1:2),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u,bmin,bmax,x,xx_vois
+ real(kind=8),dimension(-5:5,-5:5) :: ej,fj
+ real(kind=8) :: tp1,tp2,phi1,phi2
+ integer :: ib,jb
+
+
+ !particules voisines
+ !-------------------
+ do ib=-4,5
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ !coeff decentre droite = coeff decentre gauche -1
+ !-------------------------------------------------
+ do ib=-4,3
+ xx_vois(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+
+ if ((xx_vois(ib)>0.5).and.((blocg(mod(i-1+ib+npart,npart)+1)==0).or.(blocd(mod(i-1+ib+npart,npart)+1)==0))) then
+ x(ib)=xx_vois(ib)-1.
+ else
+ x(ib)=xx_vois(ib)
+ end if
+ end do
+
+
+ do ib=-4,3
+
+ bmin(ib)=min(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+ bmax(ib)=max(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+
+
+ do jb=-4,3
+ ej(ib,jb)=coeff_M5g(-2,x(jb))*u(ib+2)+coeff_M5g(-1,x(jb))*u(ib+1)+coeff_M5g(0,x(jb))*u(ib)+coeff_M5g(1,x(jb))*u(ib-1)+coeff_M5g(2,x(jb))*u(ib-2)
+ fj(ib,jb)=coeff_l4mM5g(-2,x(jb))*u(ib+1)+(coeff_l4mM5g(-2,x(jb))+coeff_l4mM5g(-1,x(jb)))*u(ib)-(coeff_l4mM5g(1,x(jb))+coeff_l4mM5g(2,x(jb)))*u(ib-1)-coeff_l4mM5g(2,x(jb))*u(ib-2)
+ end do
+
+ end do
+
+
+ do ib=-1,2
+
+ tp1=(bmin(ib-1)-ej(ib-1,ib)+max(0.,fj(ib-1,ib)))/fj(ib,ib)
+ tp2=(bmax(ib-1)-ej(ib-1,ib)+min(0.,fj(ib-1,ib)))/fj(ib,ib)
+ !phi1=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi1=max(0.,min(1.,max(tp1,tp2)))
+
+ tp1=(bmin(ib)-ej(ib,ib-1)+max(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ tp2=(bmax(ib)-ej(ib,ib-1)+min(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ !phi2=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi2=max(0.,min(1.,max(tp1,tp2)))
+
+ phi_out(ib)=min(phi1,phi2)
+
+ if(abs(fj(ib,ib))<0.0000001) phi_out(ib)=0.
+ if(abs(fj(ib,ib-1))<0.0000001) phi_out(ib)=0.
+
+ end do
+
+
+ end subroutine calcul_phi_minmax
+
+
+ end subroutine remaill_l4_limit_x
+
+
+
+
+ subroutine remaill_l4_limit_y (donne,posx,posy,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy
+ real(kind=8),dimension(1:nx,1:ny),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+ real(kind=8) :: phi_m3demi,phi_mdemi,phi_pdemi,phi_p3demi
+ real(kind=8),dimension(-1:2) :: phi
+
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+ call calcul_phi_minmax(phi)
+ phi_m3demi=phi(-1)
+ phi_mdemi=phi(0)
+ phi_pdemi=phi(1)
+ phi_p3demi=phi(2)
+
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=ca(xx)
+ poids(-1)=cb(xx)
+ poids(0)=cc(xx)
+ poids(1)=cd(xx)
+ poids(2)=ce(xx)
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=ca(xx-1.)
+ poids(0)=cb(xx-1.)
+ poids(1)=cc(xx-1)
+ poids(2)=cd(xx-1.)
+ poids(3)=ce(xx-1.)
+ poids(4)=0.
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ivar,ip(c)+1)=remaille(ivar,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+ contains
+
+ function ca(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ca
+ !ca=x*(x-1.)*(x-2.)*(x+1.)/24.
+ ca=coeff_M5g(-2,x)+phi_m3demi*coeff_l4mM5g(-2,x)
+ end function ca
+ function cb(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cb
+ !cb=-x*(x-1.)*(x**2-4.)/6.
+ cb=coeff_M5g(-1,x)-phi_m3demi*coeff_l4mM5g(-2,x)+phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))
+ end function cb
+ function cc(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cc
+ !cc=(x**2-4.)*(x**2-1.)/4.
+ cc=coeff_M5g(0,x)-phi_mdemi*(coeff_l4mM5g(-2,x)+coeff_l4mM5g(-1,x))-phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))
+ end function cc
+ function cd(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: cd
+ !cd=-x*(x+1.)*(x+2.)*(x-2.)/6.
+ cd=coeff_M5g(1,x)+phi_pdemi*(coeff_l4mM5g(1,x)+coeff_l4mM5g(2,x))-phi_p3demi*coeff_l4mM5g(2,x)
+ end function cd
+ function ce(x)
+ implicit none
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: ce
+ !ce=x*(x+1.)*(x+2.)*(x-1.)/24.
+ ce=coeff_M5g(2,x)+phi_p3demi*coeff_l4mM5g(2,x)
+ end function ce
+
+
+ function coeff_l4g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=x*(x-1)*(x-2)*(x+1)/24.
+ case(-1)
+ c=-x*(x-1)*(x-2)*(x+2)/6.
+ case(0)
+ c=(x-2)*(x-1)*(x+1)*(x+2)/4.
+ case(1)
+ c=-x*(x-2)*(x+1)*(x+2)/6.
+ case(2)
+ c=x*(x-1)*(x+1)*(x+2)/24.
+ end select
+
+ end function coeff_l4g
+
+ function coeff_M5g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=(2.*x-1.)**4/384.
+ case(-1)
+ c=19./96.-11/24.*x+x**2/4.+x**3/6.-x**4/6.
+ case(0)
+ c=115./192.-5./8.*x**2+x**4/4.
+ case(1)
+ c=19./96.+11/24.*x-x**3/6.+x**2/4.-x**4/6.
+ case(2)
+ c=(2.*x+1.)**4/384.
+ end select
+
+ end function coeff_M5g
+
+ function coeff_l4mM5g (num,x) result(c)
+ !lambda4 - M5 gauche
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-2)
+ c=5.*x/48.*(1.-x)-1./384.
+ case(-1)
+ c=-5.*x/24.*(1.-2.*x)-19/96.
+ case(0)
+ c=-5.*x**2/8.+77./192.
+ case(1)
+ c=5.*x/24.*(1.+2.*x)-19./96.
+ case(2)
+ c=-5.*x/48.*(1.+x)-1./384.
+ end select
+
+ end function coeff_l4mM5g
+
+
+
+
+ subroutine calcul_phi_minmax(phi_out)
+ implicit none
+ real(kind=8),dimension(-1:2),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u,bmin,bmax,x,xx_vois
+ real(kind=8),dimension(-5:5,-5:5) :: ej,fj
+ real(kind=8) :: tp1,tp2,phi1,phi2
+ integer :: ib,jb
+
+
+ !particules voisines
+ !-------------------
+ do ib=-4,5
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ !coeff decentre droite = coeff decentre gauche -1
+ !-------------------------------------------------
+ do ib=-4,3
+ xx_vois(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+
+ if ((xx_vois(ib)>0.5).and.((blocg(mod(i-1+ib+npart,npart)+1)==0).or.(blocd(mod(i-1+ib+npart,npart)+1)==0))) then
+ x(ib)=xx_vois(ib)-1.
+ else
+ x(ib)=xx_vois(ib)
+ end if
+ end do
+
+
+ do ib=-4,3
+
+ bmin(ib)=min(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+ bmax(ib)=max(u(ib-2),u(ib-1),u(ib),u(ib+1),u(ib+2))
+
+
+ do jb=-4,3
+ ej(ib,jb)=coeff_M5g(-2,x(jb))*u(ib+2)+coeff_M5g(-1,x(jb))*u(ib+1)+coeff_M5g(0,x(jb))*u(ib)+coeff_M5g(1,x(jb))*u(ib-1)+coeff_M5g(2,x(jb))*u(ib-2)
+ fj(ib,jb)=coeff_l4mM5g(-2,x(jb))*u(ib+1)+(coeff_l4mM5g(-2,x(jb))+coeff_l4mM5g(-1,x(jb)))*u(ib)-(coeff_l4mM5g(1,x(jb))+coeff_l4mM5g(2,x(jb)))*u(ib-1)-coeff_l4mM5g(2,x(jb))*u(ib-2)
+ end do
+
+ end do
+
+
+ do ib=-1,2
+
+ tp1=(bmin(ib-1)-ej(ib-1,ib)+max(0.,fj(ib-1,ib)))/fj(ib,ib)
+ tp2=(bmax(ib-1)-ej(ib-1,ib)+min(0.,fj(ib-1,ib)))/fj(ib,ib)
+ !phi1=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi1=max(0.,min(1.,max(tp1,tp2)))
+
+ tp1=(bmin(ib)-ej(ib,ib-1)+max(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ tp2=(bmax(ib)-ej(ib,ib-1)+min(0.,-fj(ib+1,ib-1)))/(-fj(ib,ib-1))
+ !phi2=max(0.,min(tp1,tp2),min(1.,max(tp1,tp2)))
+ phi2=max(0.,min(1.,max(tp1,tp2)))
+
+ phi_out(ib)=min(phi1,phi2)
+
+ if(abs(fj(ib,ib))<0.0000001) phi_out(ib)=0.
+ if(abs(fj(ib,ib-1))<0.0000001) phi_out(ib)=0.
+
+ end do
+
+
+ end subroutine calcul_phi_minmax
+
+ end subroutine remaill_l4_limit_y
+
+
+
+
+end module remaillage_mod
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_2d/resultats_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/resultats_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f56ed9a748dc2baeee0d263a0f9f82cba2d44485
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/resultats_mod.f90
@@ -0,0 +1,255 @@
+module resultats_mod
+ use donnees_mod
+ use tab_mod
+ contains
+
+ subroutine res_qg (nom_fich)
+ use donnees_mod
+ use tab_mod
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ open(unit=11,file=nom_fich,form="formatted")
+ do i=1,nx
+ do j=1,ny
+ x=xg+(i-1)*dx
+ y=yb+(j-1)*dy
+ write(11,'(3(f35.20,2x))') x,y,qg(i,j)
+ end do
+ end do
+ write(11,*) ""
+ write(11,*) ""
+ close (11)
+ end subroutine res_qg
+
+ subroutine res_vxg (nom_fich)
+ use donnees_mod
+ use tab_mod
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ open(unit=11,file=nom_fich,form="formatted")
+ do i=1,nx
+ do j=1,ny
+ x=xg+(i-1)*dx
+ y=yb+(j-1)*dy
+ write(11,'(3(f35.20,2x))') x,y,vxg(i,j)
+ end do
+ end do
+ write(11,*) ""
+ write(11,*) ""
+ close (11)
+ end subroutine res_vxg
+
+ subroutine res_vyg (nom_fich)
+ use donnees_mod
+ use tab_mod
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ open(unit=11,file=nom_fich,form="formatted")
+ do i=1,nx
+ do j=1,ny
+ x=xg+(i-1)*dx
+ y=yb+(j-1)*dy
+ write(11,'(3(f35.20,2x))') x,y,vyg(i,j)
+ end do
+ end do
+ write(11,*) ""
+ write(11,*) ""
+ close (11)
+ end subroutine res_vyg
+
+ subroutine res_brut (nom_fich)
+ use donnees_mod
+ use tab_mod
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ open(unit=11,file=nom_fich,form="formatted")
+ do i=1,nx
+ do j=1,ny
+ x=xg+(i-1)*dx
+ y=yb+(j-1)*dy
+ write(11,'(1(f35.20,2x))') qg(i,j)
+ end do
+ end do
+ write(11,*) ""
+ write(11,*) ""
+ close (11)
+ end subroutine res_brut
+
+
+!!$ subroutine res_qg_freq (dossier,nom_fich)
+!!$ implicit none
+!!$ character(len=*),intent(in) :: dossier
+!!$ character(len=*),intent(in) :: nom_fich
+!!$ integer :: i,j,cpt_num
+!!$
+!!$ if ((time<=cpt_fich_sauv).and.(time+dt>cpt_fich_sauv))then
+!!$ cpt_fich_sauv=cpt_fich_sauv+frequ_fich_sauv
+!!$
+!!$ if (int(time)==0) call res_vtk_q(dossier//nom_fich//char(48)//"_"//char(int(time*10.)+48)//".vtk")
+!!$ do i=1,9
+!!$ if (int(time)==i) call res_vtk_q(dossier//nom_fich//char(48+i)//"_"//char(int(mod(time,float(i))*10.)+48)//".vtk")
+!!$ end do
+!!$ cpt_num=49
+!!$ do j=10,80,10
+!!$ do i=j,j+9
+!!$ if (int(time)==i) call res_vtk_q(dossier//nom_fich//char(cpt_num)//char(48+i-j)//"_"//char(int(mod(time,float(i))*10.)+48)//".vtk")
+!!$ end do
+!!$ cpt_num=cpt_num+1
+!!$ end do
+!!$ end if
+!!$
+!!$ end subroutine res_qg_freq
+
+
+
+
+
+
+ subroutine res_vtk_q (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')"scalaire"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,1
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,0
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,0
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny
+ write(11,'(A15)') "SCALARS Q FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ do j=1,ny
+ do i=1,nx
+ write(11,'(f20.9)') real(qg(i,j))
+ end do
+ end do
+
+ close (11)
+ end subroutine res_vtk_q
+
+
+
+ subroutine res_vtk_tab (nom_fich,tab)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ real(kind=8),dimension(:,:),intent(in) :: tab
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')"scalaire"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,1
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,0
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,0
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny
+ write(11,'(A15)') "SCALARS Q FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ do j=1,ny
+ do i=1,nx
+ write(11,'(f20.9)') real(tab(i,j))
+ end do
+ end do
+
+ close (11)
+
+ end subroutine res_vtk_tab
+
+ subroutine res_vtk_v (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,1
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,0
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,0
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny
+ write(11,'(A21)') "VECTORS VITESSE FLOAT"
+
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j)),real(vyg(i,j)),0.
+ end do
+ end do
+ close (11)
+ end subroutine res_vtk_v
+
+ subroutine res_vtk (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')""
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,1
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,0
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,0
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny
+ write(11,'(A15)') "SCALARS U FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ do j=1,ny
+ do i=1,nx
+ write(11,'(f20.9)') real(qg(i,j))
+ end do
+ end do
+
+ write(11,'(A21)') ""
+ write(11,'(A21)') "VECTORS VITESSE FLOAT"
+
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j)),real(vyg(i,j)),0.
+ end do
+ end do
+
+ close (11)
+
+ end subroutine res_vtk
+
+
+
+end module resultats_mod
+
diff --git a/CodesEnVrac/CodesAdrien/split_2d/tab_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/tab_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c1b406a3f761dc3efcc660744fc115649a1df684
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/tab_mod.f90
@@ -0,0 +1,19 @@
+module tab_mod
+
+ !grille
+ real(kind=8),dimension(:,:),pointer :: qg,vxg,vyg,xtab,ytab,exa,qg_init,qg_tmp
+ real(kind=8),dimension(:,:),pointer :: vxg1,vyg1,vxg2,vyg2,vxg3,vyg3
+ integer,dimension(:,:),pointer :: numpg
+
+ !particule
+ real(kind=8),dimension(:),pointer :: xp,yp,qp,vx,vy
+ real(kind=8),dimension(:),pointer :: xp0,yp0,xp1,xp2,yp1,yp2,xp3,yp3,vx0,vy0,vx1,vx2,vx3,vy1,vy2,vy3
+ integer,dimension(:),pointer :: blocg,blocd,Nbloc,Nblocg
+
+ !debug
+ real(kind=8),dimension(:),pointer ::deb_part1
+ real(kind=8),dimension(:,:),pointer ::deb_g1
+
+
+
+end module tab_mod
diff --git a/CodesEnVrac/CodesAdrien/split_2d/utile_mod.f90 b/CodesEnVrac/CodesAdrien/split_2d/utile_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e8ca610bb2ae825bbbd2377f58db591445c6fba8
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_2d/utile_mod.f90
@@ -0,0 +1,758 @@
+module utile_mod
+ use donnees_mod
+ use tab_mod
+ use interpolation_mod
+ use advection_mod
+contains
+
+
+ subroutine make_grille
+ implicit none
+ integer :: i,j
+
+ do j=1,ny
+ do i=1,nx
+ xtab(i,j)=xg+(i-1)*dx
+ ytab(i,j)=yb+(j-1)*dy
+ end do
+ end do
+
+ end subroutine make_grille
+
+
+ function tsource(t,x,y)
+ implicit none
+ real(kind=8),intent(in) :: t,x,y
+ real(kind=8) :: tsource,t1,t2,t3,t4,t5
+
+ t1=1.
+ t2=1.
+ t3=0.2
+ t4=0.3
+ t5=1.
+
+
+ !u=u(t,x,y)
+ !----------
+ tsource=-( pi*sin(pi*t/t3)*cos(2.*pi*x/t1)*cos(2.*pi*y/t2) )/t3 - (2.*pi*t5*sin(2.*pi*x/t1)**2*sin(2.*pi*y/t1)*cos(pi*t/t4)*cos(pi*t/t3)*cos(2.*pi*y/t2) )/t1 -(2.*pi*t5*cos(2.*pi*x/t1)**2*cos(2.*pi*y/t1)*cos(pi*t/t4)*cos(pi*t/t3)*sin(2.*pi*y/t2))/t2
+
+ !tsource=0.
+
+
+ end function tsource
+
+
+
+ subroutine source_rk4
+ implicit none
+ integer :: i
+ real(kind=8) :: rk1,rk2,rk3,rk4,t1,t2,t3
+ real(kind=8) :: x1,x2,x3,y1,y2,y3,v1x,v2x,v3x,v1y,v2y,v3y
+
+
+
+ do i=1,npart
+
+ !euler
+ !------
+ ! qp(i)=qp(i)+dt*tsource(time,xp(i),yp(i))
+
+ !rk2
+ !----
+ !qp(i)=qp(i)+dt*tsource(time+0.5*dt,xp(i)+0.5*dt*vx(i),yp(i)+0.5*dt*vy(i))
+
+ !rk3
+ !---
+!!$ rk1=tsource(time,xp(i),yp(i))
+!!$ x1=xp(i)+0.5*dt*vx(i)
+!!$ y1=yp(i)+0.5*dt*vy(i)
+!!$ rk2=tsource(time+0.5*dt,x1,y1)
+!!$ call evalv (v1x,v1y,time+0.5*dt,x1,y1)
+!!$ x2=xp(i)-dt*vx(i)+2.*dt*v1x
+!!$ y2=yp(i)-dt*vy(i)+2.*dt*v1y
+!!$ rk3=tsource(time+dt,x2,y2)
+!!$
+!!$ qp(i)=qp(i)+dt*(rk1/6.+2.*rk2/3.+rk3/6.)
+
+ !rk4
+ !---
+ rk1=tsource(time,xp(i),yp(i))
+ x1=xp(i)+0.5*dt*vx(i)
+ y1=yp(i)+0.5*dt*vy(i)
+ rk2=tsource(time+0.5*dt,x1,y1)
+ call evalv (v1x,v1y,time+0.5*dt,x1,y1)
+ x2=xp(i)+0.5*dt*v1x
+ y2=yp(i)+0.5*dt*v1y
+ rk3=tsource(time+0.5*dt,x2,y2)
+ call evalv (v2x,v2y,time+0.5*dt,x2,y2)
+ x3=xp(i)+dt*v2x
+ y3=yp(i)+dt*v2y
+ rk4=tsource(time+dt,x3,y3)
+
+ qp(i)=qp(i)+dt*(rk1+2.*rk2+2.*rk3+rk4)/6.
+
+ end do
+
+
+ end subroutine source_rk4
+
+
+ subroutine source_split_1
+ implicit none
+ integer :: i,j
+ real(kind=8) :: rk1,rk2,rk3,rk4,t1,t2,t3
+ real(kind=8) :: x1,x2,x3,y1,y2,y3,v1x,v2x,v3x,v1y,v2y,v3y
+ real(kind=8) :: x,y
+
+
+ !ordre2
+ !------
+ do i=1,npart
+ qp(i)=qp(i)+0.5*dt*tsource(time,xp(i),yp(i))
+ end do
+
+
+ end subroutine source_split_1
+
+ subroutine source_split_2
+ implicit none
+ integer :: i,j
+ real(kind=8) :: rk1,rk2,rk3,rk4,t1,t2,t3
+ real(kind=8) :: x0,x1,x2,x3,y1,y2,y3,v1x,v2x,v3x,v1y,v2y,v3y
+ real(kind=8) :: x,y
+
+
+ !ordre2
+ !------
+ do j=1,ny
+ do i=1,nx
+ x=xtab(i,j)
+ y=ytab(i,j)
+
+ qg(i,j)=qg(i,j)+0.5*dt*tsource(time+dt,x,y)
+
+ end do
+ end do
+
+
+ end subroutine source_split_2
+
+
+ subroutine make_bloc(esp)
+ use donnees_mod
+ implicit none
+ integer,intent(in) :: esp
+ integer :: fin,ib,i,j,k,im,ip,dim1,dim2
+ logical :: zero
+ real(kind=8) :: pas
+
+ select case(esp)
+ case(1)
+ dim1=nx
+ dim2=ny
+ pas=dx
+ case(2)
+ dim1=ny
+ dim2=nx
+ pas=dy
+ end select
+
+
+ !-----------------------------------------------------------------------------------------
+ !Determine la nature des blocs
+ !Donne un flag correspondant au type de remaillage necessaire (centre,decentre ou modifie)
+ !------------------------------------------------------------------------------------------
+
+ blocg(1:npart)=1
+ blocd(1:npart)=1
+
+
+ ordonne: do j=1,dim2
+
+ !peut calculer la longeur -> gain si longeur eleve
+
+ !parcours la grille, bloc par bloc:determine le type des bloc
+ !---------------------------------
+
+ blocg(0)=100
+ blocd(0)=100
+ Nbloc(0)=100
+
+ type_bloc:do i=1,dim1,long_bloc+1
+
+
+ if ( (i+long_bloc)<(dim1-1) ) then
+ fin=i+long_bloc
+ call sub_typeb
+ else
+ !parcours le bloc plus premier point du bloc suivant
+ fin=dim1-1
+ call sub_typeb
+ blocg(pg(dim1,j))=blocg(pg(dim1-1,j))
+ blocd(pg(dim1,j))=blocd(pg(dim1-1,j))
+ Nbloc(pg(dim1,j))=Nbloc(pg(dim1-1,j))
+ end if
+
+ end do type_bloc
+
+
+ !parcours la grille, bloc par bloc:determine si modif de remaillage necessaire a l'intersection des blocs
+ !---------------------------------
+ type_remaill:do i=1,dim1,long_bloc+1
+
+ if (((i+long_bloc)<dim1).and.(i>1+long_bloc)) then
+ fin=i+long_bloc
+ call sub_remb
+ else
+ if (i<=1+long_bloc)then
+ !premier bloc
+ !-------------
+ fin=i+long_bloc
+ call sub_remb
+
+ else
+ !dernier bloc
+ !-------------
+ fin=dim1
+ call sub_remb
+
+ end if
+
+ end if
+
+ end do type_remaill
+ end do ordonne
+
+ contains
+
+ subroutine sub_typeb
+
+ integer :: ni,N
+ real(kind=8) :: li
+ logical :: pasfait
+
+
+ !parcours une premiere fois le bloc pour savoir si c'est un bloc en 0 ou 1/2
+ !----------------------------------
+ pasfait=.true.
+ zero=.true.
+ do_zero:do ib=i,fin+1 !eviter cas change de bloc quand maille vide
+ if (pg(ib,j)/=0) then
+ if (pasfait) then !le N doit etre le meme pour tout le bloc !
+ li=dt/pas*vit(pg(ib,j))
+ ni=floor(li+0.5)
+ pasfait=.false.
+ end if
+ li=dt/pas*vit(pg(ib,j))
+ if ( ((li)<(ni-0.5)).or.((li)>(ni+0.5)) ) then
+ zero=.false.
+ exit do_zero
+ end if
+ end if
+ end do do_zero
+
+
+ !parcours a nouveau le bloc
+ !-------------------------
+ !affecte le type de bloc a toute les part du bloc
+
+ pasfait=.true.
+ bloc2:do ib=i,fin
+
+ if (pg(ib,j)/=0) then
+
+ !calcul de N
+ !------------
+ if (pasfait) then
+ if (zero) then
+ N=floor(dt/pas*vit(pg(ib,j))+0.5)
+ pasfait=.false.
+ else
+ N=floor(dt/pas*vit(pg(ib,j)))
+ pasfait=.false.
+ end if
+ end if
+
+ if (zero) then
+ !bloc pour lambda2 centre
+ blocg(pg(ib,j))=0
+ blocd(pg(ib,j))=0
+ end if
+
+ !affecte la constante N
+ Nbloc(pg(ib,j))=N
+
+ end if
+ end do bloc2
+
+ end subroutine sub_typeb
+
+
+ subroutine sub_remb
+ implicit none
+
+ integer,dimension(-2:2) :: iper
+ integer :: k
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection de ces blocs
+
+ bloc3:do ib=i,fin,fin-i
+
+ if (pg(ib,j)/=0) then
+
+ !si fin de bloc en 0. :
+ !----------------------
+ do k=-2,2
+ iper(k)=pg(mod(ib+k+dim1-1,dim1)+1,j)
+ end do
+
+
+ if ((ib==fin).and.(blocd(pg(ib,j))==0).and.((blocg(iper(1))==1).or.(blocg(iper(2))==1)).and.((Nbloc(iper(1))==Nbloc(pg(ib,j))-1) .or.(Nbloc(iper(2))==Nbloc(pg(ib,j))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j))<=Nbloc(pg(ib,j)) ) then
+ blocg(iper(1))=2
+ blocd(pg(ib,j))=3
+ else
+ blocg(iper(1))=2
+ blocd(pg(ib,j))=4
+ blocg(pg(ib,j))=5
+ end if
+
+ else
+ blocg(iper(1))=2
+ blocg(iper(2))=5
+
+ if ( dt/pas*vit(pg(ib,j))<=Nbloc(pg(ib,j)) ) then
+ blocd(pg(ib,j))=3
+ else
+ blocd(pg(ib,j))=7
+ blocg(pg(ib,j))=8
+ end if
+
+ if ( dt/pas*vit(iper(-1))<=Nbloc(pg(ib,j)) ) then
+ blocd(iper(-1))=6
+ else
+ blocd(iper(-1))=5
+ end if
+ end if
+
+ end if
+
+
+ !si debut de bloc en 0 : detecte quelle correction il faudra apporter
+ !----------------------
+ if ((ib==i) .and.(blocg(pg(ib,j))==0).and.((blocd(iper(-1))==1).or.(blocd(iper(-2))==1)).and.((Nbloc(iper(-1))==Nbloc(pg(ib,j))-1) .or. (Nbloc(iper(-2))==Nbloc(pg(ib,j))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j))>Nbloc(pg(ib,j)) ) then
+ blocd(iper(-1))=2
+ blocg(pg(ib,j))=4
+ else
+ blocd(iper(-1))=2
+ blocg(pg(ib,j))=3
+ end if
+
+ else
+
+ blocd(iper(-1))=2
+ blocd(iper(-2))=4
+
+ if ( dt/pas*vit(pg(ib,j))>Nbloc(pg(ib,j)) ) then
+ blocg(pg(ib,j))=4
+ else
+ blocg(pg(ib,j))=3
+ end if
+
+ if ( dt/pas*vit(iper(1))>Nbloc(pg(ib,j)) ) then
+ blocg(iper(1))=7
+ else
+ blocg(iper(1))=6
+ end if
+
+ end if
+ end if
+
+
+
+ end if
+ end do bloc3
+
+ end subroutine sub_remb
+
+ function pg(a,b)
+ implicit none
+ integer,intent(in) :: a,b
+ integer :: pg
+
+ select case (esp)
+ case(1)
+ pg=numpg(a,b)
+ case(2)
+ pg=numpg(b,a)
+ end select
+
+ end function pg
+
+ function vit(ind)
+ implicit none
+ integer,intent(in) :: ind
+ real(kind=8) :: vit
+
+ select case (esp)
+ case(1)
+ vit=vx(ind)
+ case(2)
+ vit=vy(ind)
+ end select
+
+ end function vit
+
+
+ end subroutine make_bloc
+
+
+
+ subroutine make_bloc_v2(esp)
+ use donnees_mod
+ implicit none
+ integer,intent(in) :: esp
+ integer :: fin,ib,i,j,k,im,ip,dim1,dim2,n,np,part,partp,partm,partpp
+ logical :: zero
+ real(kind=8) :: pas
+
+ select case(esp)
+ case(1)
+ dim1=nx
+ dim2=ny
+ pas=dx
+ case(2)
+ dim1=ny
+ dim2=nx
+ pas=dy
+ end select
+
+
+ !-----------------------------------------------------------------------------------------
+ !Determine la nature des blocs
+ !Donne un flag correspondant au type de remaillage necessaire (centre,decentre ou modifie)
+ !------------------------------------------------------------------------------------------
+
+ blocg(1:npart)=0
+ blocd(1:npart)=0
+
+ blocg(0)=100
+ blocd(0)=100
+ Nbloc(0)=100
+
+ ordonne: do j=1,dim2
+
+ !peut calculer la longeur -> gain si longeur eleve
+
+ !parcours la grille, bloc par bloc:determine le type des bloc
+ !---------------------------------
+
+
+
+ type_bloc:do i=1,dim1,long_bloc+1
+
+
+ if ( (i+long_bloc).le.dim1 ) then
+ fin=i+long_bloc
+ call sub_typeb
+ else
+ !met les dernieres particules du meme type que bloc precedent
+ do k=i,dim1
+ blocg(pg(k,j))=blocg(pg(i-1,j))
+ blocd(pg(k,j))=blocd(pg(i-1,j))
+ Nbloc(pg(k,j))=Nbloc(pg(i-1,j))
+ end do
+ end if
+
+ end do type_bloc
+
+
+ !parcours la grille, bloc par bloc:determine si modif de remaillage necessaire a l'intersection des blocs
+ !---------------------------------
+ type_remaill:do i=1,dim1,long_bloc+1
+
+ if ((i+long_bloc)<dim1) then
+ fin=i+long_bloc
+ !call sub_remb
+
+ k=fin
+ do while ((pg(k,j)==0).and.(k>i))
+ k=k-1
+ end do
+ n=Nbloc(pg(k,j)) ! s'il n'y a pas de part dans le bloc N=100 -> ne fera pas de correction
+
+ k=fin+1
+ do while ((pg(k,j)==0).and.(k<(fin+long_bloc+2)).and.(k<nx))
+ k=k+1
+ end do
+ np=Nbloc(pg(k,j))
+
+ part=pg(fin,j)
+ partp=pg(fin+1,j)
+ partm=pg(fin-1,j)
+ partpp=pg(fin+2,j)
+
+ if (type_b==2) call sub_remb_2(n,np,part,partp)
+ if (type_b==4) call sub_remb_4(n,np,part,partp,partm,partpp)
+
+ else
+ !dernier bloc
+ !-------------
+ fin=dim1
+ !call sub_remb
+
+ k=fin
+ do while ((pg(k,j)==0).and.(k>i))
+ k=k-1
+ end do
+ n=Nbloc(pg(k,j))
+
+ k=1
+ do while ((pg(k,j)==0).and.(k<(1+long_bloc+1)))
+ k=k+1
+ end do
+ np=Nbloc(pg(k,j))
+
+ part=pg(fin,j)
+ partp=pg(1,j)
+ partm=pg(fin-1,j)
+ partpp=pg(2,j)
+
+ if (type_b==2) call sub_remb_2(n,np,part,partp)
+ if (type_b==4) call sub_remb_4(n,np,part,partp,partm,partpp)
+
+
+ end if
+
+ end do type_remaill
+
+
+
+ end do ordonne
+
+ contains
+
+ subroutine sub_typeb
+
+ integer :: N,intl
+ real(kind=8) :: li,lmin
+
+
+ !calcul de lambda_min
+ !--------------------
+ lmin=99999999999999999999999.
+ do_lmin:do ib=i,fin
+ if (pg(ib,j)/=0) then
+ li=dt/pas*vit(pg(ib,j))
+ lmin=min(lmin,li)
+ end if
+ end do do_lmin
+
+ !calcul du type de bloc et de N
+ !-------------------------------
+ intl=floor(lmin)
+ if ((lmin-intl).le.0.5) then
+ !type gauche
+ !-----------
+ N=intl
+ do_typeg:do ib=i,fin
+ if (pg(ib,j)/=0) then
+ blocg(pg(ib,j))=1
+ blocd(pg(ib,j))=1
+ Nbloc(pg(ib,j))=N
+ end if
+ end do do_typeg
+ else
+ !type centre
+ !-----------
+ N=intl+1
+ do_typec:do ib=i,fin
+ if (pg(ib,j)/=0) then
+ blocg(pg(ib,j))=0
+ blocd(pg(ib,j))=0
+ Nbloc(pg(ib,j))=N
+ end if
+ end do do_typec
+ end if
+
+
+ end subroutine sub_typeb
+
+
+
+ subroutine sub_remb_2(n,np,partf,partfp)
+ !attention les bords ne sont pas bien traités
+ implicit none
+
+ integer,intent(in) ::n,np,partf,partfp
+ real(kind=8) :: li
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection des blocs
+ if ((np) == (n-1)) then
+ li=dt/pas*vit(partf)
+ if ( (li<n).and.(blocg(partf)==0) ) then !seconde condition=bloc centre
+ blocg(partf)=2
+ else
+ blocg(partf)=3
+ end if
+ blocg(partfp)=4
+ end if
+ if ((np) == (n+1)) then
+ li=dt/pas*vit(partfp)
+ blocg(partf)=5
+ if ((li<np).and.(blocg(partfp)==0)) then
+ blocg(partfp)=6
+ else
+ blocg(partfp)=7
+ end if
+ end if
+
+
+
+ end subroutine sub_remb_2
+
+
+ subroutine sub_remb_4(n,np,partf,partfp,partfm,partfpp)
+ !attention les bords ne sont pas bien traités
+ implicit none
+
+ integer,intent(in) ::n,np,partf,partfp,partfm,partfpp
+ real(kind=8) :: li
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection des blocs
+
+ !N_{m+1}=N_m -1
+ !--------------
+ if ((np) == (n-1)) then
+ !si bloc centre
+ if (blocd(partfm)==0) then
+ li=dt/pas*vit(partfm)
+ if ( (li<n) ) then
+ blocd(partfm)=2
+ else
+ blocd(partfm)=3
+ end if
+ else
+ blocd(partfm)=3
+ end if
+ if (blocg(partf)==0) then
+ li=dt/pas*vit(partf)
+ if ( (li<n) ) then
+ blocg(partf)=2
+ blocd(partf)=4
+ else
+ blocg(partf)=3
+ blocd(partf)=5
+ end if
+ else
+ blocg(partf)=3
+ blocd(partf)=5
+ end if
+ blocg(partfp)=4
+ blocd(partfp)=1
+ li=dt/pas*vit(partfpp)
+ if ( (blocg(partfpp)==0).and.(li<np) ) then
+ blocg(partfpp)=5
+ else
+ blocg(partfpp)=6
+ end if
+ end if
+ !N_{m+1}=N_m +1
+ !--------------
+ if ((np) == (n+1)) then
+ li=dt/pas*vit(partfm)
+ if ( (blocd(partfm)==0).and.(li<n) ) then
+ blocd(partfm)=6
+ else
+ blocd(partfm)=7
+ end if
+ blocg(partf)=1
+ blocd(partf)=8
+ if (blocg(partfp)==0) then
+ li=dt/pas*vit(partfp)
+ if ( (li<np) ) then
+ blocg(partfp)=7
+ blocd(partfp)=0
+ else
+ blocg(partfp)=8
+ blocd(partfp)=1
+ end if
+ else
+ blocg(partfp)=8
+ blocd(partfp)=1
+ end if
+ if (blocg(partfpp)==0) then
+ li=dt/pas*vit(partfpp)
+ if ( (li<np) ) then
+ blocg(partfpp)=9
+ else
+ blocg(partfpp)=10
+ end if
+ else
+ blocg(partfpp)=10
+ end if
+
+ end if
+
+
+
+ end subroutine sub_remb_4
+
+
+
+ function pg(a,b)
+ implicit none
+ integer,intent(in) :: a,b
+ integer :: pg
+
+ select case (esp)
+ case(1)
+ pg=numpg(a,b)
+ case(2)
+ pg=numpg(b,a)
+ end select
+
+ end function pg
+
+ function vit(ind)
+ implicit none
+ integer,intent(in) :: ind
+ real(kind=8) :: vit
+
+ select case (esp)
+ case(1)
+ vit=vx(ind)
+ case(2)
+ vit=vy(ind)
+ end select
+
+ end function vit
+
+
+ end subroutine make_bloc_v2
+
+
+
+
+
+
+
+end module utile_mod
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/Makefile b/CodesEnVrac/CodesAdrien/split_3d_rapide/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..17d0e77ef14580711262137f79ab141d79e4f9e3
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/Makefile
@@ -0,0 +1,25 @@
+#
+# Makefile
+#
+#Compilateur = ifort
+Compilateur = ifort -pg
+#Compilateur = ifort -O0 -debug
+Programme = split_3d
+FILES = donnees_mod.f90 tab_mod.f90 init_mod.f90 remaillage_mod.f90 interpolation_mod.f90 advection_mod.f90 resultats_mod.f90 utile_mod.f90 main.f90
+OBJS = $(patsubst %.f90, %.o, $(FILES))
+
+$(Programme): $(OBJS)
+ @echo edition de liens
+ @$(Compilateur) $(OBJS) -o $@
+
+%.o: %.f90
+ @echo compilation de $?
+ @$(Compilateur) -c $?
+
+clean:
+ @rm -f *.o *~ *.mod
+ @echo nettoyage
+
+clean_all:
+ @rm -f *.o *~ *.mod *exe *.out
+ @echo nettoyage
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/advection_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/advection_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..94667e3ffab99f119114099e266a13982d723233
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/advection_mod.f90
@@ -0,0 +1,664 @@
+module advection_mod
+ use donnees_mod
+ use tab_mod
+ use remaillage_mod
+ use interpolation_mod
+contains
+
+ subroutine def_v_advec (vitx,vity,vitz,tps)
+ implicit none
+
+ real(kind=8),intent(in) :: tps
+ real(kind=8),dimension(1:nx_gro,1:ny_gro,1:nz_gro),intent(out) :: vitx,vity,vitz
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,r2,tmp,r,per,t3
+ real,dimension(1:nx_gro,1:ny_gro,1:nz_gro) :: tvitx,tvity,tvitz
+
+
+ !-------------------
+ !deformation sphere:
+ !--------------------
+!!$ do k=1,nz_gro
+!!$ z=zd+(k-1)*dz_gro
+!!$ do j=1,ny_gro
+!!$ y=yb+(j-1)*dy_gro
+!!$ do i=1,nx_gro
+!!$ x=xg+(i-1)*dx_gro
+!!$
+!!$ !t3=0.3
+!!$ !t3=3.
+!!$ !t3=1.
+!!$
+!!$ if (tps<=1.) then
+!!$ vitx(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z) !*cos(pi*tps/t3)
+!!$ vity(i,j,k)=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z) !*cos(pi*tps/t3)
+!!$ vitz(i,j,k)=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2 !*cos(pi*tps/t3)
+!!$ else
+!!$ vitx(i,j,k)=-2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z)
+!!$ vity(i,j,k)=sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)
+!!$ vitz(i,j,k)=sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2
+!!$ end if
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+
+
+ !----------------------------------
+ !deformation sphere: test tps
+ !----------------------------------
+
+!!$ do k=1,nz_gro
+!!$ z=zd+(k-1)*dz_gro
+!!$ do j=1,ny_gro
+!!$ y=yb+(j-1)*dy_gro
+!!$ do i=1,nx_gro
+!!$ x=xg+(i-1)*dx_gro
+!!$
+!!$
+!!$ vitx(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z) *cos(2.*pi*tps)
+!!$ vity(i,j,k)=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)*cos(2.*pi*tps)
+!!$ vitz(i,j,k)=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2*cos(2.*pi*tps)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$ !----------------------------------
+!!$ !deformation sphere: calta
+!!$ !----------------------------------
+!!$
+!!$
+!!$ do k=1,nz_gro
+!!$ z=zd+(k-1)*dz_gro
+!!$ do j=1,ny_gro
+!!$ y=yb+(j-1)*dy_gro
+!!$ do i=1,nx_gro
+!!$ x=xg+(i-1)*dx_gro
+!!$
+!!$ !calta: pas à div=0
+!!$ !--------------------
+!!$ !vitx(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)**2*sin(2.*pi*z)**2 *cos(pi*tps/3.)
+!!$ !vity(i,j,k)=-sin(2.*pi*x)**2*sin(pi*y)**2*sin(2.*pi*z)**2 *cos(pi*tps/3.)
+!!$ !vitz(i,j,k)=-2.*sin(2.*pi*x)**2*sin(2.*pi*y)**2*sin(pi*z)**2 *cos(pi*tps/3.)
+!!$
+!!$
+!!$ !Petros + terme en temps
+!!$ !------------------------
+!!$ vitx(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z) *cos(pi*tps/3.)
+!!$ vity(i,j,k)=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z) *cos(pi*tps/3.)
+!!$ vitz(i,j,k)=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2 *cos(pi*tps/3.)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+ !----------------------------------
+ !champ turbulent de gh
+ !----------------------------------
+
+
+ open(20,file='datavelx',form='unformatted',convert='big_endian',status='unknown')
+ read(20) (((tvitx(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+ close(20)
+
+ open(20,file='datavely',form='unformatted',convert='big_endian',status='unknown')
+ read(20) (((tvity(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+ close(20)
+
+ open(20,file='datavelz',form='unformatted',convert='big_endian',status='unknown')
+ read(20) (((tvitz(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+ close(20)
+
+ vitx=tvitx
+ vity=tvity
+ vitz=tvitz
+
+
+
+ end subroutine def_v_advec
+
+
+
+
+
+
+ subroutine evalv (vitx,vity,vitz,tps,x,y,z)
+ implicit none
+ real(kind=8),intent(in) :: tps,x,y,z
+ real(kind=8),intent(out) :: vitx,vity,vitz
+ integer :: i,j,k
+ real(kind=8) :: t3
+
+
+ t3=0.3
+
+ vitx=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z) *cos(pi*tps/t3)
+ vity=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z) *cos(pi*tps/t3)
+ vitz=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2 *cos(pi*tps/t3)
+
+ end subroutine evalv
+
+
+
+
+
+
+
+ subroutine crea_part_x
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff!*maxval(abs(qg))
+ npart=0
+ numpg=0
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ if (abs(qg(i,j,k))>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l5(vxg,x,y,z)
+ !vy(npart)=interpol_v_l5(vyg,x,y,z)
+ !vz(npart)=interpol_v_l5(vzg,x,y,z)
+ qp(npart)=qg(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_x
+
+ subroutine crea_part_y
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff!*maxval(abs(qg))
+ npart=0
+ numpg=0
+ do k=1,nz
+ z=ztab(k)
+ do i=1,nx
+ x=xtab(i)
+ do j=1,ny
+ y=ytab(j)
+
+ if (abs(qg(i,j,k))>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l5(vxg,x,y,z)
+ !vy(npart)=interpol_v_l5(vyg,x,y,z)
+ !vz(npart)=interpol_v_l5(vzg,x,y,z)
+ qp(npart)=qg(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_y
+
+ subroutine crea_part_z
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff!*maxval(abs(qg))
+ npart=0
+ numpg=0
+
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+ do k=1,nz
+ z=ztab(k)
+
+ if (abs(qg(i,j,k))>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l5(vxg,x,y,z)
+ !vy(npart)=interpol_v_l5(vyg,x,y,z)
+ !vz(npart)=interpol_v_l5(vzg,x,y,z)
+ qp(npart)=qg(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_z
+
+
+ !==================
+ !TENSORIEL
+ !==================
+
+ subroutine ad_tenso_euler
+ implicit none
+
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ do i=1,npart
+ xp(i)=xp(i)+dt*vx(i)
+ yp(i)=yp(i)+dt*vy(i)
+ zp(i)=zp(i)+dt*vz(i)
+ end do
+
+ end subroutine ad_tenso_euler
+
+ subroutine ad_tenso_rk2
+ implicit none
+ integer :: ib
+ !allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+
+ !call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx)
+ !call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy)
+ !call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz)
+
+ !call interpo_l3_3d(vxg,xp1,yp1,zp1,vx)
+ !call interpo_l3_3d(vyg,xp1,yp1,zp1,vy)
+ !call interpo_l3_3d(vzg,xp1,yp1,zp1,vz)
+
+ call interpo_l2_3d(vxg,xp1,yp1,zp1,vx)
+ call interpo_l2_3d(vyg,xp1,yp1,zp1,vy)
+ call interpo_l2_3d(vzg,xp1,yp1,zp1,vz)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*vx(ib)
+ yp(ib)=yp(ib)+dt*vy(ib)
+ zp(ib)=zp(ib)+dt*vz(ib)
+ end do
+
+ !deallocate(xp1,yp1,zp1)
+ end subroutine ad_tenso_rk2
+
+
+ subroutine ad_tenso_rk3
+ implicit none
+ integer :: ib
+
+
+ !allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp1(1:npart),zp2(1:npart))
+ !allocate (vx1(1:npart),vx2(1:npart),vy1(1:npart),vy2(1:npart),vz1(1:npart),vz2(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+
+ call interpo_l3_3d(vxg,xp1,yp1,zp1,vx1)
+ call interpo_l3_3d(vyg,xp1,yp1,zp1,vy1)
+ call interpo_l3_3d(vzg,xp1,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)+2.*vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+2.*vy1(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)+2.*vz1(ib))
+ end do
+
+ call interpo_l3_3d(vxg,xp2,yp2,zp2,vx2)
+ call interpo_l3_3d(vyg,xp2,yp2,zp2,vy2)
+ call interpo_l3_3d(vzg,xp2,yp2,zp2,vz2)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*(vx(ib)/6.+2.*vx1(ib)/3.+vx2(ib)/6.)
+ yp(ib)=yp(ib)+dt*(vy(ib)/6.+2.*vy1(ib)/3.+vy2(ib)/6.)
+ zp(ib)=zp(ib)+dt*(vz(ib)/6.+2.*vz1(ib)/3.+vz2(ib)/6.)
+ end do
+
+ ! deallocate (xp1,xp2,yp1,yp2,zp1,zp2)
+ ! deallocate (vx1,vx2,vy1,vy2,vz1,vz2)
+
+
+ end subroutine ad_tenso_rk3
+
+ subroutine ad_tenso_rk4
+ implicit none
+ integer :: ib
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+
+ call interpo_l4_3d(vxg,xp1,yp1,zp1,vx1)
+ call interpo_l4_3d(vyg,xp1,yp1,zp1,vy1)
+ call interpo_l4_3d(vzg,xp1,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+0.5*dt*vx1(ib)
+ yp2(ib)=yp(ib)+0.5*dt*vy1(ib)
+ zp2(ib)=zp(ib)+0.5*dt*vz1(ib)
+ end do
+
+ call interpo_l4_3d(vxg,xp2,yp2,zp2,vx2)
+ call interpo_l4_3d(vyg,xp2,yp2,zp2,vy2)
+ call interpo_l4_3d(vzg,xp2,yp2,zp2,vz2)
+
+ do ib=1,npart
+ xp3(ib)=xp(ib)+dt*vx2(ib)
+ yp3(ib)=yp(ib)+dt*vy2(ib)
+ zp3(ib)=zp(ib)+dt*vz2(ib)
+ end do
+
+ call interpo_l4_3d(vxg,xp3,yp3,zp3,vx3)
+ call interpo_l4_3d(vyg,xp3,yp3,zp3,vy3)
+ call interpo_l4_3d(vzg,xp3,yp3,zp3,vz3)
+
+ do ib=1,npart
+ xp(ib)=xp(ib)+dt*(vx(ib)+2.*vx1(ib)+2.*vx2(ib)+vx3(ib))/6.
+ yp(ib)=yp(ib)+dt*(vy(ib)+2.*vy1(ib)+2.*vy2(ib)+vy3(ib))/6.
+ zp(ib)=zp(ib)+dt*(vz(ib)+2.*vz1(ib)+2.*vz2(ib)+vz3(ib))/6.
+ end do
+
+
+ end subroutine ad_tenso_rk4
+
+
+
+ subroutine ad_euler_x
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ xp(i)=xp(i)+dt*vx(i)
+ end do
+
+ end subroutine ad_euler_x
+
+ subroutine ad_euler_y
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ yp(i)=yp(i)+dt*vy(i)
+ end do
+
+ end subroutine ad_euler_y
+
+ subroutine ad_euler_z
+ implicit none
+
+ integer :: i
+
+ do i=1,npart
+ zp(i)=zp(i)+dt*vz(i)
+ end do
+
+ end subroutine ad_euler_z
+
+
+ !===============================
+ !SPLITTING
+ !calcul de la vitesse pour une advection d'euler à l'ordre 2 ou 3
+ !===============================
+
+ subroutine update_vx_2
+ implicit none
+ integer :: ib
+
+ !allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+ !call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx)
+ !call interpo_l3_3d(vxg,xp1,yp1,zp1,vx)
+ call interpo_l2_3d(vxg,xp1,yp1,zp1,vx)
+ !deallocate(xp1,yp1,zp1)
+ end subroutine update_vx_2
+
+ subroutine update_vy_2
+ implicit none
+ integer :: ib
+
+ !allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)-0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+ !call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy)
+ !call interpo_l3_3d(vyg,xp1,yp1,zp1,vy)
+ call interpo_l2_3d(vyg,xp1,yp1,zp1,vy)
+ !deallocate(xp1,yp1,zp1)
+ end subroutine update_vy_2
+
+ subroutine update_vz_2
+ implicit none
+ integer :: ib
+
+ !allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)-0.5*dt*vx(ib)
+ yp1(ib)=yp(ib)-0.5*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+ !call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz)
+ !call interpo_l3_3d(vzg,xp1,yp1,zp1,vz)
+ call interpo_l2_3d(vzg,xp1,yp1,zp1,vz)
+ !deallocate(xp1,yp1,zp1)
+ end subroutine update_vz_2
+
+
+
+ subroutine update_vx_3
+ implicit none
+ integer :: ib
+
+
+ !allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp1(1:npart),zp2(1:npart))
+ !allocate (vx1(1:npart),vx2(1:npart),vx3(1:npart),vx4(1:npart),vy1(1:npart),vz1(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+2.*dt*vx(ib)/3.
+ yp1(ib)=yp(ib)+2.*dt*vy(ib)/3.
+ zp1(ib)=zp(ib)+2.*dt*vz(ib)/3.
+ end do
+
+ !call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx1)
+ !call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy1)
+ !call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz1)
+
+ call interpo_l3_3d(vxg,xp1,yp1,zp1,vx1)
+ call interpo_l3_3d(vyg,xp1,yp1,zp1,vy1)
+ call interpo_l3_3d(vzg,xp1,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)+vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+vy1(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)+vz1(ib))
+ end do
+
+ call interpo_l3_3d(vxg,xp2,yp,zp,vx2)
+ call interpo_l3_3d(vxg,xp,yp2,zp,vx3)
+ call interpo_l3_3d(vxg,xp,yp,zp2,vx4)
+
+ do ib=1,npart
+ vx(ib)=-0.5*vx(ib)+3.*vx1(ib)/4.+vx2(ib)/4.+vx3(ib)/4.+vx4(ib)/4.
+ end do
+
+ !deallocate (xp1,xp2,yp1,yp2,zp1,zp2)
+ !deallocate (vx1,vx2,vx3,vx4,vy1,vz1)
+
+
+ end subroutine update_vx_3
+
+ subroutine update_vy_3
+ implicit none
+ integer :: ib,i,j
+
+ !allocate (xp0(1:npart),xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp1(1:npart),zp2(1:npart))
+ !allocate (vx1(1:npart),vz1(1:npart),vy1(1:npart),vy2(1:npart),vy3(1:npart),vy4(1:npart),vy5(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)-dt*vx(ib)/3.
+ yp1(ib)=yp(ib)+2.*dt*vy(ib)/3.
+ zp1(ib)=zp(ib)+2.*dt*vz(ib)/3.
+ xp0(ib)=xp(ib)-4.*dt*vx(ib)/3.
+ end do
+
+ !call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx1)
+ !call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy1)
+ !call interpo_l3_3d(vyg1,xp0,yp1,zp1,vy2)
+ !call interpo_l3_3d(vzg1,xp0,yp1,zp1,vz1)
+
+ call interpo_l3_3d(vxg,xp1,yp1,zp1,vx1)
+ call interpo_l3_3d(vyg,xp1,yp1,zp1,vy1)
+ call interpo_l3_3d(vyg,xp0,yp1,zp1,vy2)
+ call interpo_l3_3d(vzg,xp0,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(vx(ib)-2.*vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+vy2(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)/4.+vz1(ib)/4.)
+ end do
+
+ call interpo_l3_3d(vyg,xp2,yp,zp,vy3)
+ call interpo_l3_3d(vyg,xp,yp2,zp,vy4)
+ call interpo_l3_3d(vyg,xp,yp,zp2,vy5)
+
+ do ib=1,npart
+ vy(ib)=-5.*vy(ib)/4.+3.*vy1(ib)/4.+vy3(ib)/4.+vy4(ib)/4.+vy5(ib)
+ end do
+
+
+ !deallocate (xp0,xp1,xp2,yp1,yp2,zp1,zp2)
+ !deallocate (vx1,vz1,vy1,vy2,vy3,vy4,vy5)
+
+ end subroutine update_vy_3
+
+ subroutine update_vz_3
+ implicit none
+ integer :: ib,i,j,k
+
+ !allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp0(1:npart),zp1(1:npart),zp2(1:npart))
+ !allocate (vx1(1:npart),vy1(1:npart),vz1(1:npart),vz2(1:npart),vz3(1:npart),vz4(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)-2.*dt*vx(ib)/3.
+ yp1(ib)=yp(ib)-2.*dt*vy(ib)/3.
+ zp1(ib)=zp(ib)+dt*vz(ib)/3.
+ zp0(ib)=zp(ib)+4.*dt*vz(ib)/3.
+ end do
+
+ !call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz1)
+ !call interpo_l3_3d(vxg2,xp1,yp1,zp0,vx1)
+ !call interpo_l3_3d(vyg2,xp1,yp1,zp0,vy1)
+
+ call interpo_l3_3d(vzg,xp1,yp1,zp1,vz1)
+ call interpo_l3_3d(vxg,xp1,yp1,zp0,vx1)
+ call interpo_l3_3d(vyg,xp1,yp1,zp0,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)+vx1(ib))
+ yp2(ib)=yp(ib)+dt*(vy(ib)-vy1(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)+2.*vz1(ib))
+ end do
+
+ call interpo_l3_3d(vzg,xp2,yp,zp,vz2)
+ call interpo_l3_3d(vzg,xp,yp2,zp,vz3)
+ !call interpo_l3_3d(vzg3,xp,yp,zp2,vz4)
+ call interpo_l3_3d(vzg,xp,yp,zp2,vz4)
+
+ do ib=1,npart
+ vz(ib)=3.*vz1(ib)/4.-vz2(ib)/4.+vz3(ib)/4.+vz4(ib)/4.
+ end do
+
+
+ !deallocate (xp1,xp2,yp1,yp2,zp0,zp1,zp2)
+ !deallocate (vx1,vy1,vz1,vz2,vz3,vz4)
+
+ end subroutine update_vz_3
+
+
+
+
+
+ !==================================
+ !STRANG
+ !==================================
+
+ subroutine update_vx_strang
+ implicit none
+ integer :: ib
+
+ !allocate (xp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5*dt*vx(ib)
+ end do
+ !call interpo_l2_3d(vxg,xp1,yp,zp,vx)
+ call interpo_l2_1d_x(vxg,xp1,yp,zp,vx)
+ !deallocate(xp1)
+ end subroutine update_vx_strang
+
+ subroutine update_vy_strang
+ implicit none
+ integer :: ib
+
+ !allocate (yp1(1:npart))
+ do ib=1,npart
+ yp1(ib)=yp(ib)+0.5*dt*vy(ib)
+ end do
+ !call interpo_l2_3d(vyg,xp,yp1,zp,vy)
+ call interpo_l2_1d_y(vyg,xp,yp1,zp,vy)
+ !deallocate(yp1)
+ end subroutine update_vy_strang
+
+ subroutine update_vz_strang
+ implicit none
+ integer :: ib
+
+ !allocate (zp1(1:npart))
+ do ib=1,npart
+ zp1(ib)=zp(ib)+0.5*dt*vz(ib)
+ end do
+ !call interpo_l2_3d(vzg,xp,yp,zp1,vz)
+ call interpo_l2_1d_z(vzg,xp,yp,zp1,vz)
+ !deallocate(zp1)
+ end subroutine update_vz_strang
+
+
+
+
+
+end module advection_mod
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/donnees_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/donnees_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9a4223ecf037cadae1475e450db8d45080f0c930
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/donnees_mod.f90
@@ -0,0 +1,10 @@
+module donnees_mod
+
+ integer :: nx,ny,nz,nx_gro,ny_gro,nz_gro,npg,npart,ideb,npart_init,npart_t1
+ integer :: kx,ky,kz,type_b,long_bloc
+ real(kind=8) :: time,dx,dy,dz,dx_gro,dy_gro,dz_gro,xg,xd,yb,yh,zd,zf,dt,tfin,cfl,pi
+ real(kind=8) :: xdeb,cutoff,dt_sauv
+ character(len=90) :: nom_fich_vtk,name_err,dossier,nom_fich_tps_cpu
+
+
+end module donnees_mod
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/init_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/init_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7eb85c85d9463ec656704362a5bace45bbdb12f4
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/init_mod.f90
@@ -0,0 +1,89 @@
+module init_mod
+ !
+ !initialisation des valeurs sur la grille
+ !
+contains
+ subroutine init_grille
+ use donnees_mod
+ use tab_mod
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,r,t2
+
+ !------------
+ !sphere
+ !------------
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ y=ytab(j)
+!!$ do i=1,nx
+!!$ x=xtab(i)
+!!$
+!!$ r=sqrt((x-0.35)**2+(y-0.35)**2+(z-0.35)**2)
+!!$ qg(i,j,k)=0.
+!!$ if (r<=0.15) qg(i,j,k)=1.
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+
+
+!!$ !---gaussienne sur [0,1]^3-------------------------
+!!$ !----------------------------------------------------
+!!$
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ y=ytab(j)
+!!$ do i=1,nx
+!!$ x=xtab(i)
+!!$
+!!$ qg(i,j,k)=(1.-((x-0.5)**2+(y-0.5)**2+(z-0.5)**2))**6
+!!$ if (((x-0.5)**2+(y-0.5)**2+(z-0.5)**2)>1.) qg(i,j,k)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+
+
+!!$ !------------
+!!$ !cos / sin
+!!$ !------------
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ y=ytab(j)
+!!$ do i=1,nx
+!!$ x=xtab(i)
+!!$
+!!$ t2=0.2
+!!$ qg(i,j,k)=cos(pi*time/t2)*cos(2.*pi*x)*cos(2.*pi*y)*cos(2.*pi*z)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+
+
+ !------------
+ !test
+ !------------
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ qg(i,j,k)=1.
+
+ end do
+ end do
+ end do
+
+ end subroutine init_grille
+
+
+
+end module init_mod
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/interpolation_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/interpolation_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7e24e74ede50f2103defdc5d7349690ccbcbd617
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/interpolation_mod.f90
@@ -0,0 +1,883 @@
+module interpolation_mod
+ use donnees_mod
+ contains
+
+ subroutine interpo_l4_3d(tab_grille,posx,posy,posz,tab_part)
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb
+ integer,dimension(0:5) :: ip,jp,kp
+ real(kind=8),dimension(0:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,y2,y3,y4,z2,z3,z4
+
+ tab_part(1:npart)=0.
+
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(2) - 2
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+ kp(5) = kp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ if (yy1<=0.5) then
+ poidy(0)=(2.*yy1-y2-2*y3+y4)/24.
+ poidy(1)=(-4.*yy1+4.*y2+y3-y4)/6.
+ poidy(2)=1.+(-5.*y2+y4)/4.
+ poidy(3)=(4.*yy1+4.*y2-y3-y4)/6.
+ poidy(4)=(-2.*yy1-y2+2*y3+y4)/24.
+ poidy(5)=0.
+ else
+ poidy(0)=0.
+ poidy(1)=(-6.*yy1+11.*y2-6.*y3+y4)/24.
+ poidy(2)=1.+(-5.*yy1-5.*y2+5.*y3-y4)/6.
+ poidy(3)=(6.*yy1+y2-4.*y3+y4)/4.
+ poidy(4)=(-3.*yy1+y2+3.*y3-y4)/6.
+ poidy(5)=(2.*yy1-y2-2.*y3+y4)/24.
+ end if
+ if (zz1<=0.5) then
+ poidz(0)=(2.*zz1-z2-2*z3+z4)/24.
+ poidz(1)=(-4.*zz1+4.*z2+z3-z4)/6.
+ poidz(2)=1.+(-5.*z2+z4)/4.
+ poidz(3)=(4.*zz1+4.*z2-z3-z4)/6.
+ poidz(4)=(-2.*zz1-z2+2*z3+z4)/24.
+ poidz(5)=0.
+ else
+ poidz(0)=0.
+ poidz(1)=(-6.*zz1+11.*z2-6.*z3+z4)/24.
+ poidz(2)=1.+(-5.*zz1-5.*z2+5.*z3-z4)/6.
+ poidz(3)=(6.*zz1+z2-4.*z3+z4)/4.
+ poidz(4)=(-3.*zz1+z2+3.*z3-z4)/6.
+ poidz(5)=(2.*zz1-z2-2.*z3+z4)/24.
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,5
+ do d=0,5
+ do c=0,5
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine interpo_l4_3d
+
+ subroutine interpo_l3_3d(tab_grille,posx,posy,posz,tab_part)
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb
+ integer,dimension(0:3) :: ip,jp,kp
+ real(kind=8),dimension(0:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+ kp(1) = floor((posz(i)-zd)/dz_gro)
+ kp(0) = kp(1) - 1
+ kp(2) = kp(1) + 1
+ kp(3) = kp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=0,3
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ poidy(0)=-1./6.*yy1*(yy1-1.)*(yy1-2.)
+ poidy(1)=0.5*(1.-yy1)*(1.+yy1)*(2.-yy1)
+ poidy(2)=-0.5*yy1*(yy1+1.)*(yy1-2.)
+ poidy(3)=1/6.*yy1*(1.+yy1)*(yy1-1.)
+
+ poidz(0)=-1./6.*zz1*(zz1-1.)*(zz1-2.)
+ poidz(1)=0.5*(1.-zz1)*(1.+zz1)*(2.-zz1)
+ poidz(2)=-0.5*zz1*(zz1+1.)*(zz1-2.)
+ poidz(3)=1/6.*zz1*(1.+zz1)*(zz1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,3
+ do d=0,3
+ do c=0,3
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine interpo_l3_3d
+
+
+ subroutine interpo_l2_3d(tab_grille,posx,posy,posz,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb,kb,e
+ integer,dimension(0:2) :: ip,jp,kp
+ real(kind=8),dimension(0:2) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+
+ kp(1) = floor((posz(i)-zd)/dz_gro)
+ kp(0) = kp(1) - 1
+ kp(2) = kp(1) + 1
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro !relatif
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz_gro-zd)/dz_gro !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=0,2
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=0.5*xx1*(xx1-1.)
+ poidx(1)=1.-xx1**2
+ poidx(2)=0.5*xx1*(1.+xx1)
+
+ poidy(0)=0.5*yy1*(yy1-1.)
+ poidy(1)=1.-yy1**2
+ poidy(2)=0.5*yy1*(1.+yy1)
+
+ poidz(0)=0.5*zz1*(zz1-1.)
+ poidz(1)=1.-zz1**2
+ poidz(2)=0.5*zz1*(1.+zz1)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,2
+ do d=0,2
+ do e=0,2
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine interpo_l2_3d
+
+ subroutine interpo_l1_3d(tab_grille,posx,posy,posz,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,ib,jb,kb,e
+ integer,dimension(1:2) :: ip,jp,kp
+ real(kind=8),dimension(1:2) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1
+
+ tab_part=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(2) = ip(1) + 1
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(2) = jp(1) + 1
+
+ kp(1) = floor((posz(i)-zd)/dz_gro)
+ kp(2) = kp(1) + 1
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro !relatif
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro !relatif
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz_gro-zd)/dz_gro !relatif
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=1,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=1,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=1,2
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(1)=1.-xx1
+ poidx(2)=xx1
+
+ poidy(1)=1.-yy1
+ poidy(2)=yy1
+
+ poidz(1)=1.-zz1
+ poidz(2)=zz1
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=1,2
+ do d=1,2
+ do e=1,2
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine interpo_l1_3d
+
+
+
+ subroutine interpo_l2_1d_x(tab_grille,posx,posy,posz,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ tab_part(1:npart)=0.
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-1,2
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jvar,kvar)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine interpo_l2_1d_x
+
+ subroutine interpo_l2_1d_y(tab_grille,posx,posy,posz,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ tab_part(1:npart)=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-1,2
+ tab_part(i)=tab_part(i)+tab_grille(ivar,ip(c)+1,kvar)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine interpo_l2_1d_y
+
+ subroutine interpo_l2_1d_z(tab_grille,posx,posy,posz,tab_part)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ tab_part(1:npart)=0.
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-1,2
+ tab_part(i)=tab_part(i)+tab_grille(ivar,jvar,ip(c)+1)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine interpo_l2_1d_z
+
+
+
+ !===========================================================================
+ !pour interpoler le champ de vitesse de la grille grossiere à la grille fine
+ !===========================================================================
+
+
+ function interpol_v_l1(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(0:1) :: ip,jp,kp
+ real(kind=8),dimension(0:1) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(1) = ip(0)+1
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(1) = jp(0)+1
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(1) = kp(0)+1
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,1
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,1
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=0,1
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=1.-xx
+ poidx(1)=xx
+
+ poidy(0)=1.-yy
+ poidy(1)=yy
+
+ poidz(0)=1.-zz
+ poidz(1)=zz
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,1
+ do c=0,1
+ do d=0,1
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l1
+
+ function interpol_v_l3(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(-1:2) :: ip,jp,kp
+ real(kind=8),dimension(-1:2) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(-1) = kp(0)-1
+ kp(1) = kp(0)+1
+ kp(2) = kp(0)+2
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-1,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=-1,2
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(-1)=-1./6.*xx*(xx-1.)*(xx-2.)
+ poidx(0)=0.5*(1.-xx)*(1.+xx)*(2.-xx)
+ poidx(1)=-0.5*xx*(xx+1.)*(xx-2.)
+ poidx(2)=1/6.*xx*(1.+xx)*(xx-1.)
+
+ poidy(-1)=-1./6.*yy*(yy-1.)*(yy-2.)
+ poidy(0)=0.5*(1.-yy)*(1.+yy)*(2.-yy)
+ poidy(1)=-0.5*yy*(yy+1.)*(yy-2.)
+ poidy(2)=1/6.*yy*(1.+yy)*(yy-1.)
+
+ poidz(-1)=-1./6.*zz*(zz-1.)*(zz-2.)
+ poidz(0)=0.5*(1.-zz)*(1.+zz)*(2.-zz)
+ poidz(1)=-0.5*zz*(zz+1.)*(zz-2.)
+ poidz(2)=1/6.*zz*(1.+zz)*(zz-1.)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-1,2
+ do c=-1,2
+ do d=-1,2
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidy(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l3
+
+ function interpol_v_l5(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(-2:3) :: ip,jp,kp
+ real(kind=8),dimension(-2:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+ real(kind=8) :: x2,x3,x4,x5,y2,y3,y4,y5
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-2) = ip(0)-2
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+ ip(3) = ip(0)+3
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-2) = jp(0)-2
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+ jp(3) = jp(0)+3
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(-2) = kp(0)-2
+ kp(-1) = kp(0)-1
+ kp(1) = kp(0)+1
+ kp(2) = kp(0)+2
+ kp(3) = kp(0)+3
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-2,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=-2,3
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ x2=xx**2
+ x3=xx**3
+ x4=xx**4
+ x5=xx**5
+ y2=yy**2
+ y3=yy**3
+ y4=yy**4
+ y5=yy**5
+
+ poidx(-2)=xx/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(-1)=-xx/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(0)=1.-xx/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(1)=xx+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(2)=-xx/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(3)=xx/30.-x3/24.+x5/120.
+
+ poidy(-2)=yy/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(-1)=-yy/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(0)=1.-yy/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(1)=yy+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(2)=-yy/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(3)=yy/30.-y3/24.+y5/120.
+
+ poidz(-2)=zz/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidz(-1)=-zz/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidz(0)=1.-zz/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidz(1)=zz+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidz(2)=-zz/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidz(3)=zz/30.-y3/24.+y5/120.
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-2,3
+ do c=-2,3
+ do d=-2,3
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l5
+
+
+
+
+ end module interpolation_mod
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/main.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..87be5adbead22acd19b7dd1a4993f975fca8b804
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/main.f90
@@ -0,0 +1,706 @@
+program split
+ !--------------------------------------------------------------------------
+ !etude de l'ordre pour splitting 3D
+ !
+ !--------------------------------------------------------------------------
+ use donnees_mod ! donnees
+ use tab_mod ! donnees dans tableaux
+ use init_mod ! init_grille
+ use advection_mod ! crea_part,advection
+ use remaillage_mod ! remaill_4m_centre (formules de remaillage)
+ use interpolation_mod ! formules d'interpolation (pour range kutta)
+ use resultats_mod ! res_grille_tps,res_grille_freq
+ use utile_mod
+
+
+ real(kind=8) :: x,y
+ integer :: n
+ real(kind=8) :: time1,time2,time3,time4,dt_deb,maxv
+
+ !pour test
+ integer :: c,i,j,cpt_ite,ib,jb,k,cpt,nx_boucle
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8,t9,tmp,dt_boucle,r,grad,div
+
+
+ !lecture données
+ !---------------
+ open(unit=10,file="parameter",form="formatted")
+ read(10,*) xg,xd,yb,yh,zd,zf
+ read(10,*) tfin
+ read(10,*) cutoff
+ read(10,*) type_b
+ read(10,*) long_bloc
+ read(10,*) nom_fich_vtk
+ read(10,*) name_err
+ read(10,*) dossier
+ read(10,*) nom_fich_tps_cpu
+ close(10)
+
+
+ name_err=trim(name_err)
+
+ call cpu_time(t1)
+
+ erreur:do nx_boucle=129,129
+
+ open(unit=10,file="parameter",form="formatted")
+ read(10,*) xg,xd,yb,yh,zd,zf
+ close (10)
+
+ nx=nx_boucle
+ ny=nx_boucle
+ nz=nx_boucle
+
+ nx_gro=nx
+ ny_gro=nx_gro
+ nz_gro=nx_gro
+
+ dx=(xd-xg)/(nx-1.)
+ dy=(yh-yb)/(ny-1.)
+ dz=(zf-zd)/(nz-1.)
+
+ dx_gro=(xd-xg)/(nx_gro-1.)
+ dy_gro=(yh-yb)/(ny_gro-1.)
+ dz_gro=(zf-zd)/(nz_gro-1.)
+
+
+ maxv=2.
+ !maxv=3.3
+ !maxv=1.
+ cfl=0.4
+ !cfl=5.
+ !cfl=14.
+ !cfl=4.
+! cfl=8.
+
+ !cfl=2.*0.025252525252525/dx! cfl5
+ !cfl=2.*0.02424242520573163/dx !cfl 4.8
+
+
+
+ !print*,"cfl=",cfl
+
+ dt=cfl*dx/maxv
+! dt=2./150.
+
+ dt=0.049
+
+ print*,"dt",dt
+
+ !
+ !calcul init
+ !-----------
+ cpt_ite=0
+ time=0.
+
+
+ npart=nx*ny*nz
+
+
+ xd=xd-1./nx !pour conditions periodiques
+ yh=yh-1./ny
+ zf=zf-1./nz
+
+ nx=nx-1
+ ny=ny-1
+ nz=nz-1
+
+ nx_gro=nx_gro-1
+ ny_gro=ny_gro-1
+ nz_gro=nz_gro-1
+
+
+ pi=4.*atan(1.)
+
+ !
+ !alloc tableaux
+ !--------------
+ call alloc_sub
+
+ open(unit=29,file=name_err,form="formatted")
+ call cpu_time(t2)
+
+ !
+ !initialisation
+ !--------------
+ call make_grille
+ call init_grille()
+
+ cutoff=cutoff*maxval(abs(qg))
+
+
+ !=============================
+ !champ de vitesse
+ !=============================
+ call def_v_advec (vxg,vyg,vzg,time)
+
+
+ !
+ !boucle temps
+ !------------
+ temps: do while(time<tfin)
+
+ !print*,"cflmax:",dt*max(maxval(vxg),maxval(vyg),maxval(vzg))/dx
+
+ !if ((time+dt)>tfin) dt=tfin-time
+
+ if (time<=2.*dt) dt_deb=dt
+
+
+ call crea_part_x()
+
+ if (time<dt) npart_init=npart
+ if ((time<=1.).and.(time+dt>1.)) npart_t1=npart
+
+
+ !================================
+ !si remaillage tenso en espace
+ !================================
+
+!!$ !RK2
+!!$ !allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+!!$ !call def_v_advec (vxg1,vyg1,vzg1,time+0.5*dt)
+!!$
+!!$ !RK3
+!!$ !allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+!!$ !allocate(vxg2(1:nx_gro,1:ny_gro,1:nz_gro),vyg2(1:nx_gro,1:ny_gro,1:nz_gro),vzg2(1:nx_gro,1:ny_gro,1:nz_gro))
+!!$ !call def_v_advec (vxg1,vyg1,vzg1,time+0.5*dt)
+!!$ !call def_v_advec (vxg2,vyg2,vzg2,time+dt)
+!!$
+!!$
+!!$ !t source:rk4
+!!$ !------------
+!!$ !call source_rk4
+!!$
+!!$ !advection
+!!$ !---------
+!!$ !call ad_tenso_euler
+!!$ call ad_tenso_rk2
+!!$ !call ad_tenso_rk3
+!!$ !call ad_tenso_rk4
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ call remaill_l2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l3(qp,xp,yp,zp,qg)
+!!$ !call remaill_l4(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8(qp,xp,yp,zp,qg)
+!!$ !call remaill_mp4(qp,xp,yp,zp,qg)
+!!$
+!!$ !deallocate(vxg1,vyg1,vzg1)
+!!$ !deallocate(vxg2,vyg2,vzg2)
+!!$
+
+ !=====================
+ !splitting en espace
+ !=====================
+!!$
+ !RK2
+ !allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+ !call def_v_advec (vxg1,vyg1,vzg1,time +0.5*dt)
+ !vxg1=vxg
+ !vyg1=vyg
+ !vzg1=vzg
+
+ !RK3
+ !allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+ !allocate(vxg2(1:nx_gro,1:ny_gro,1:nz_gro),vyg2(1:nx_gro,1:ny_gro,1:nz_gro),vzg2(1:nx_gro,1:ny_gro,1:nz_gro))
+ !allocate(vxg3(1:nx_gro,1:ny_gro,1:nz_gro),vyg3(1:nx_gro,1:ny_gro,1:nz_gro),vzg3(1:nx_gro,1:ny_gro,1:nz_gro))
+ !call def_v_advec (vxg1,vyg1,vzg1,time+2.*dt/3.)
+
+
+ !t source
+ !---------
+ !call source_split_1
+
+ !test v
+ !-------
+ !print*,"vmax grille",max(maxval(abs(vxg)),maxval(abs(vyg)),maxval(abs(vzg)))
+ !print*,"vmax interpole",max(maxval(abs(vx)),maxval(abs(vy)),maxval(abs(vz)))
+
+
+ !update v
+ !--------
+ !call update_vx_2
+ !call update_vx_3
+
+ !print*,"vmax interpole rk2",max(maxval(abs(vx)),maxval(abs(vy)),maxval(abs(vz)))
+ !stop
+
+ !test cfl
+ !========
+ !print*,"test cfl en x "
+ !print*,"cfl,cflpart en x",dt/dx*maxval(abs(vxg)),dt/dx*maxval(abs(vx))
+! ainf=0.
+! do k=1,nz
+! do j=1,ny
+! do i=1,nx-1
+! if ( (numpg(i+1,j,k)/=0).and.(numpg(i,j,k)/=0) ) ainf=max(ainf,abs(vx(numpg(i+1,j,k))-vx(numpg(i,j,k))))
+! end do
+! end do
+! end do
+! if (dt>(0.5*dx/(ainf))) then
+! print*,""
+! print*,"cfl l2 viole" ,dt,0.5*dx/(ainf),0.5*dx/(2.*ainf)
+! print*,""
+! end if
+! if (dt>(0.5*dx/(2.*ainf))) then
+! print*,""
+! print*,"cfl l4 viole" ,dt,0.5*dx/(ainf),0.5*dx/(2.*ainf)
+! print*,""
+! end if
+! if (dt>(0.5*dx/(3.*ainf))) then
+! print*,""
+! print*,"cfl l4 papier viole" ,dt,0.5*dx/(2.*ainf),0.5*dx/(3.*ainf)
+! print*,""
+! end if
+ !fin test
+ !--------
+
+
+ !bloc x
+ !-------
+ !call make_bloc(1)
+ call make_bloc_v2(1)
+ !blocg=0
+ !blocd=0
+
+ !advection
+ !----------
+ call ad_euler_x
+
+
+ !remaillage
+ !----------
+ if (type_b==200) call remaill_l2_x(qp,xp,yp,zp,qg)
+ if (type_b==400) call remaill_l4_x(qp,xp,yp,zp,qg)
+ !call remaill_l5_x(qp,xp,yp,zp,qg)
+ if (type_b==600) call remaill_l6_x(qp,xp,yp,zp,qg)
+ !call remaill_l8_x(qp,xp,yp,zp,qg)
+ if (type_b==2) call remaill_l2_bloc_x_v2(qp,xp,yp,zp,qg)
+ if (type_b==4) call remaill_l4_bloc_x_v2(qp,xp,yp,zp,qg)
+ if (type_b==20) call limit_l2_bloc_x(qp,xp,yp,zp,qg)
+
+ !contrainte cfl
+ !--------------
+ ! grad=0.
+ ! do k=1,nz_gro
+ ! do j=1,ny_gro
+ ! do i=1,nx_gro-1
+ ! if ((numpg(i+1,j,k)/=0).and.(numpg(i,j,k)/=0)) grad=max(grad,abs(vx(numpg(i+1,j,k))-vx(numpg(i,j,k)))/dx)
+ ! end do
+ ! end do
+ ! end do
+
+
+
+
+ !y
+ !--
+ call crea_part_y()
+ !call crea_part_x()
+
+
+ !update v
+ !--------
+ !call update_vy_2
+ !call update_vy_3
+
+ !bloc y
+ !-------
+ !call make_bloc(2)
+ call make_bloc_v2(2)
+ !blocg=0
+ !blocd=0
+
+ !advection
+ !----------
+ call ad_euler_y
+ !remaillage
+ !----------
+ if (type_b==200) call remaill_l2_y(qp,xp,yp,zp,qg)
+ if (type_b==400) call remaill_l4_y(qp,xp,yp,zp,qg)
+ !call remaill_l5_y(qp,xp,yp,zp,qg)
+ if (type_b==600) call remaill_l6_y(qp,xp,yp,zp,qg)
+ !call remaill_l8_y(qp,xp,yp,zp,qg)
+ if (type_b==2)call remaill_l2_bloc_y_v2(qp,xp,yp,zp,qg)
+ if (type_b==4)call remaill_l4_bloc_y_v2(qp,xp,yp,zp,qg)
+ if (type_b==20) call limit_l2_bloc_y(qp,xp,yp,zp,qg)
+
+ !contrainte cfl
+ !--------------
+ ! do k=1,nz_gro
+ ! do j=1,ny_gro-1
+ ! do i=1,nx_gro
+ ! if ((numpg(i,j+1,k)/=0).and.(numpg(i,j,k)/=0)) grad=max(grad,abs(vy(numpg(i,j+1,k))-vy(numpg(i,j,k)))/dy)
+ ! end do
+ ! end do
+ ! end do
+
+
+
+ !z
+ !--
+ call crea_part_z()
+ !call crea_part_x()
+
+ !update v
+ !--------
+ !call update_vz_2
+ !call update_vz_3
+
+ !call def_v_advec (vxg1,vyg1,vzg1,time+dt/3.)
+ !call def_v_advec (vxg2,vyg2,vzg2,time+4.*dt/3.)
+ !call def_v_advec (vxg3,vyg3,vzg3,time+dt)
+ !call update_vz_3
+
+ !bloc z
+ !-------
+ !call make_bloc(3)
+ call make_bloc_v2(3)
+ !blocg=0
+ !blocd=0
+
+ !advection
+ !----------
+ call ad_euler_z
+
+ !remaillage
+ !----------
+ if (type_b==200) call remaill_l2_z(qp,xp,yp,zp,qg)
+ if (type_b==400) call remaill_l4_z(qp,xp,yp,zp,qg)
+ !call remaill_l5_z(qp,xp,yp,zp,qg)
+ if (type_b==600) call remaill_l6_z(qp,xp,yp,zp,qg)
+ !call remaill_l8_z(qp,xp,yp,zp,qg)
+ if (type_b==2)call remaill_l2_bloc_z_v2(qp,xp,yp,zp,qg)
+ if (type_b==4)call remaill_l4_bloc_z_v2(qp,xp,yp,zp,qg)
+ if (type_b==20) call limit_l2_bloc_z(qp,xp,yp,zp,qg)
+
+ !contrainte cfl
+ !--------------
+ ! do k=1,nz_gro-1
+ ! do j=1,ny_gro
+ ! do i=1,nx_gro
+ ! if ((numpg(i,j,k+1)/=0).and.(numpg(i,j,k)/=0)) grad=max(grad,abs(vz(numpg(i,j,k+1))-vz(numpg(i,j,k)))/dz)
+ ! end do
+ ! end do
+ ! end do
+
+ ! print*,"t=0,dt,1/(4.*grad),1/(6.*grad)"
+ ! print*,"(vitesse sur part)"
+ ! print*,dt,1./(4.*grad),1./(6.*grad)
+
+
+ !t source
+ !---------
+ !call source_split_2
+
+
+ !deallocate(vxg1,vyg1,vzg1)
+ !deallocate(vxg2,vyg2,vzg2)
+ !deallocate(vxg3,vyg3,vzg3)
+
+
+
+
+ !=================
+ !splitting strang
+ !=================
+
+!!$ !allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+!!$ !call def_v_advec (vxg1,vyg1,vzg1,time+0.5*dt)
+!!$
+!!$ !t source
+!!$ !--------
+!!$ !call source_split_1
+!!$
+!!$ dt_sauv=dt
+!!$ dt=0.5*dt
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_strang
+!!$
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ !call make_bloc_v2(1)
+!!$ !blocg=0
+!!$ !blocd=0
+!!$
+!!$
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !if (type_b==2)call remaill_l2_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l2_x(qp,xp,yp,zp,qg)
+!!$ call remaill_l4_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l5_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8_x(qp,xp,yp,zp,qg)
+!!$
+!!$ !y
+!!$ !--
+!!$ call crea_part_y()
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_strang
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ !call make_bloc_v2(2)
+!!$ !blocg=0
+!!$ !blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !if (type_b==2)call remaill_l2_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l2_y(qp,xp,yp,zp,qg)
+!!$ call remaill_l4_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l5_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8_y(qp,xp,yp,zp,qg)
+!!$
+!!$
+!!$ !z
+!!$ !--
+!!$ call crea_part_z()
+!!$
+!!$ dt=dt_sauv
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vz_strang
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ !call make_bloc_v2(3)
+!!$ !blocg=0
+!!$ !blocd=0
+!!$
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_z
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !if (type_b==2)call remaill_l2_bloc_z_v2(qp,xp,yp,zp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_z_v2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l2_z(qp,xp,yp,zp,qg)
+!!$ call remaill_l4_z(qp,xp,yp,zp,qg)
+!!$ !call remaill_l5_z(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6_z(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8_z(qp,xp,yp,zp,qg)
+!!$
+!!$
+!!$ !y
+!!$ !--
+!!$ call crea_part_y()
+!!$ dt=0.5*dt
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_strang
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ !call make_bloc_v2(2)
+!!$ !blocg=0
+!!$ !blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !if (type_b==2)call remaill_l2_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l2_y(qp,xp,yp,zp,qg)
+!!$ call remaill_l4_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l5_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6_y(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8_y(qp,xp,yp,zp,qg)
+!!$
+!!$
+!!$ !x
+!!$ !--
+!!$ call crea_part_x()
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_strang
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ !call make_bloc_v2(1)
+!!$ !blocg=0
+!!$ !blocd=0
+!!$
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !if (type_b==2)call remaill_l2_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$ !if (type_b==4)call remaill_l4_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$ !call remaill_l2_x(qp,xp,yp,zp,qg)
+!!$ call remaill_l4_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l5_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l6_x(qp,xp,yp,zp,qg)
+!!$ !call remaill_l8_x(qp,xp,yp,zp,qg)
+!!$
+!!$
+!!$ dt=dt_sauv
+!!$
+!!$ !t source
+!!$ !--------
+!!$ !call source_split_2
+!!$
+!!$ !deallocate(vxg1,vyg1,vzg1)
+
+
+
+
+
+
+ !==========================
+ !splitting additif ordre 1
+ !===========================
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ call make_bloc_v2(1)
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_x(qp,xp,yp,zp,qg)
+!!$ if (type_b==2)call remaill_l2_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$ if (type_b==4)call remaill_l4_bloc_x_v2(qp,xp,yp,zp,qg)
+!!$
+!!$ !y
+!!$ !--
+!!$ call crea_part_y()
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ call make_bloc_v2(2)
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_y(qp,xp,yp,zp,qg)
+!!$ if (type_b==2)call remaill_l2_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$ if (type_b==4)call remaill_l4_bloc_y_v2(qp,xp,yp,zp,qg)
+!!$
+!!$
+!!$ !z
+!!$ !--
+!!$ call crea_part_z()
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ call make_bloc_v2(3)
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_z
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_z(qp,xp,yp,zp,qg)
+!!$ if (type_b==2)call remaill_l2_bloc_z_v2(qp,xp,yp,zp,qg)
+!!$ if (type_b==4)call remaill_l4_bloc_z_v2(qp,xp,yp,zp,qg)
+
+
+
+
+
+
+ ! write(29,'(3(e18.10,2x))') time,minval(qg),maxval(qg)
+
+
+
+ time=time+dt
+ cpt_ite=cpt_ite+1
+
+
+
+
+
+ end do temps
+
+
+
+ ! write(29,'(4(e18.10,2x))') dt_deb,dx,dx*dy*dz*sum(abs(exa-qg)),sqrt(dx*dy*dz*sum((exa-qg)**2))
+
+
+ end do erreur
+
+ call cpu_time(t3)
+
+ !resultat final
+ !--------------
+ print*,"tps final",time
+ print*,"nbre d'ite",cpt_ite
+ print*,"nart final",npart
+ print*,"dt,dt_fin,dx,dy,dz",dt_deb,dt,dx,dy,dz
+ print*,"temps cpu",nom_fich_vtk,t3-t1,t3-t2
+
+
+
+ call res_vtk_q(trim(dossier)//trim(nom_fich_vtk))
+ !call res_vtk("RES/vtk/"//nom_fich_vtk)
+
+ open(unit=10,file=trim(dossier)//"tps/"//trim(nom_fich_tps_cpu),form="formatted")
+ write(10,*) t3-t1,t3-t2
+ write(10,*) npart_init,npart_t1,npart
+
+ !
+ !dealloc fermeture
+ !-----------------
+ close(50)
+ close(51)
+ close(52)
+ close(53)
+ close(66)
+ close(67)
+ close(10)
+ close(29)
+
+ deallocate (xp,qp,vx,vy,yp,zp,vz)
+ deallocate (qg,vxg,vyg,vzg)
+ deallocate (xtab,ytab,ztab)
+ deallocate (xp1,yp1,zp1)
+ deallocate (xp2,yp2,zp2)
+ deallocate (xp3,yp3,zp3)
+ deallocate (numpg,blocg,blocd,Nbloc)
+ !deallocate (exa)
+
+
+end program split
+
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/parameter b/CodesEnVrac/CodesAdrien/split_3d_rapide/parameter
new file mode 100644
index 0000000000000000000000000000000000000000..07a0d9f7f905c1d9d7de64e1859611921dc1ae1d
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/parameter
@@ -0,0 +1,9 @@
+0. 1. 0. 1. 0. 1. ! xg xd yb yh zd zf
+0.0001 ! TFin
+0. 0.0001 0.0001 0.1 !cutoff
+4 ! type bloc
+3 !longeur bloc
+"vtk/test_o1_long_b_3.vtk" ! sortie fin vtk
+"RES/test.er" ! fichier erreur
+"/users/these/magni/parmes/trunk/Remesh/split_3d_rapide/RES/" "/home/magni/split_3d_rapide/" "RES/vtk/" !dossier
+"test.tps" ! fichier tps cpu
\ No newline at end of file
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/remaillage_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/remaillage_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..41f2f0647170e147fa20034feb93726b3eb3af21
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/remaillage_mod.f90
@@ -0,0 +1,4938 @@
+module remaillage_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+ subroutine remaill_l2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(1:4) :: ip,jp,kp
+ real(kind=8),dimension(1:4) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=1,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=1,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=1,4
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5) then
+
+ poidx(1)=-0.5*xx1*(1.-xx1)
+ poidx(2)=1.-xx1**2
+ poidx(3)=0.5*xx1*(1.+xx1)
+ poidx(4)=0.
+
+ else
+
+ poidx(1)=0.
+ poidx(2)=0.5*(xx1-1.)*(xx1-2.)
+ poidx(3)=xx1*(2.-xx1)
+ poidx(4)=0.5*xx1*(xx1-1.)
+
+ end if
+
+ if (yy1<=0.5) then
+
+ poidy(1)=-0.5*yy1*(1.-yy1)
+ poidy(2)=1.-yy1**2
+ poidy(3)=0.5*yy1*(1.+yy1)
+ poidy(4)=0.
+
+ else
+
+ poidy(1)=0.
+ poidy(2)=0.5*(yy1-1.)*(yy1-2.)
+ poidy(3)=yy1*(2.-yy1)
+ poidy(4)=0.5*yy1*(yy1-1.)
+
+ end if
+
+ if (zz1<=0.5) then
+
+ poidz(1)=-0.5*zz1*(1.-zz1)
+ poidz(2)=1.-zz1**2
+ poidz(3)=0.5*zz1*(1.+zz1)
+ poidz(4)=0.
+
+ else
+
+ poidz(1)=0.
+ poidz(2)=0.5*(zz1-1.)*(zz1-2.)
+ poidz(3)=zz1*(2.-zz1)
+ poidz(4)=0.5*zz1*(zz1-1.)
+
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=1,4
+ do d=1,4
+ do c=1,4
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l2
+
+ subroutine remaill_l3 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:3) :: ip,jp,kp
+ real(kind=8),dimension(0:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ kp(1) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(1) - 1
+ kp(2) = kp(1) + 1
+ kp(3) = kp(1) + 2
+
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,3
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ poidy(0)=-1./6.*yy1*(yy1-1.)*(yy1-2.)
+ poidy(1)=0.5*(1.-yy1)*(1.+yy1)*(2.-yy1)
+ poidy(2)=-0.5*yy1*(yy1+1.)*(yy1-2.)
+ poidy(3)=1/6.*yy1*(1.+yy1)*(yy1-1.)
+
+ poidz(0)=-1./6.*zz1*(zz1-1.)*(zz1-2.)
+ poidz(1)=0.5*(1.-zz1)*(1.+zz1)*(2.-zz1)
+ poidz(2)=-0.5*zz1*(zz1+1.)*(zz1-2.)
+ poidz(3)=1/6.*zz1*(1.+zz1)*(zz1-1.)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,3
+ do d=0,3
+ do c=0,3
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l3
+
+ subroutine remaill_mp4 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:3) :: ip,jp,kp
+ real(kind=8),dimension(0:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+
+ kp(1) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(1) - 1
+ kp(2) = kp(1) + 1
+ kp(3) = kp(1) + 2
+
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,3
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ poidx(0)=-0.5*xx1+x2-0.5*x3
+ poidx(1)=1-5./2.*x2+3.*0.5*x3
+ poidx(2)=0.5*xx1+2.*x2-3.*0.5*x3
+ poidx(3)=-0.5*x2+0.5*x3
+
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+ poidy(0)=-0.5*yy1+y2-0.5*y3
+ poidy(1)=1-5./2.*y2+3.*0.5*y3
+ poidy(2)=0.5*yy1+2.*y2-3.*0.5*y3
+ poidy(3)=-0.5*y2+0.5*y3
+
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+ z5=zz1**5
+ poidz(0)=-0.5*zz1+z2-0.5*z3
+ poidz(1)=1-5./2.*z2+3.*0.5*z3
+ poidz(2)=0.5*zz1+2.*z2-3.*0.5*z3
+ poidz(3)=-0.5*z2+0.5*z3
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,3
+ do d=0,3
+ do c=0,3
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_mp4
+
+ subroutine remaill_l4 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:5) :: ip,jp,kp
+ real(kind=8),dimension(0:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(2) - 2
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+ kp(5) = kp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+
+ if (xx1<=0.5) then
+ poidx(0)=(2.*xx1-x2-2*x3+x4)/24.
+ poidx(1)=(-4.*xx1+4.*x2+x3-x4)/6.
+ poidx(2)=1.+(-5.*x2+x4)/4.
+ poidx(3)=(4.*xx1+4.*x2-x3-x4)/6.
+ poidx(4)=(-2.*xx1-x2+2*x3+x4)/24.
+ poidx(5)=0.
+ else
+ poidx(0)=0.
+ poidx(1)=(-6.*xx1+11.*x2-6.*x3+x4)/24.
+ poidx(2)=1.+(-5.*xx1-5.*x2+5.*x3-x4)/6.
+ poidx(3)=(6.*xx1+x2-4.*x3+x4)/4.
+ poidx(4)=(-3.*xx1+x2+3.*x3-x4)/6.
+ poidx(5)=(2.*xx1-x2-2.*x3+x4)/24.
+ end if
+
+ if (yy1<=0.5) then
+ poidy(0)=(2.*yy1-y2-2*y3+y4)/24.
+ poidy(1)=(-4.*yy1+4.*y2+y3-y4)/6.
+ poidy(2)=1.+(-5.*y2+y4)/4.
+ poidy(3)=(4.*yy1+4.*y2-y3-y4)/6.
+ poidy(4)=(-2.*yy1-y2+2*y3+y4)/24.
+ poidy(5)=0.
+ else
+ poidy(0)=0.
+ poidy(1)=(-6.*yy1+11.*y2-6.*y3+y4)/24.
+ poidy(2)=1.+(-5.*yy1-5.*y2+5.*y3-y4)/6.
+ poidy(3)=(6.*yy1+y2-4.*y3+y4)/4.
+ poidy(4)=(-3.*yy1+y2+3.*y3-y4)/6.
+ poidy(5)=(2.*yy1-y2-2.*y3+y4)/24.
+ end if
+ if (zz1<=0.5) then
+ poidz(0)=(2.*zz1-z2-2*z3+z4)/24.
+ poidz(1)=(-4.*zz1+4.*z2+z3-z4)/6.
+ poidz(2)=1.+(-5.*z2+z4)/4.
+ poidz(3)=(4.*zz1+4.*z2-z3-z4)/6.
+ poidz(4)=(-2.*zz1-z2+2*z3+z4)/24.
+ poidz(5)=0.
+ else
+ poidz(0)=0.
+ poidz(1)=(-6.*zz1+11.*z2-6.*z3+z4)/24.
+ poidz(2)=1.+(-5.*zz1-5.*z2+5.*z3-z4)/6.
+ poidz(3)=(6.*zz1+z2-4.*z3+z4)/4.
+ poidz(4)=(-3.*zz1+z2+3.*z3-z4)/6.
+ poidz(5)=(2.*zz1-z2-2.*z3+z4)/24.
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,5
+ do d=0,5
+ do c=0,5
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l4
+
+ subroutine remaill_l5 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:5) :: ip,jp,kp
+ real(kind=8),dimension(0:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(2) - 2
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+ kp(5) = kp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+ z5=zz1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ poidy(0)=yy1/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(1)=-yy1/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(2)=1.-yy1/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(3)=yy1+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(4)=-yy1/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(5)=yy1/30.-y3/24.+y5/120.
+
+ poidz(0)=zz1/20.-z2/24.-z3/24.+z4/24.-z5/120.
+ poidz(1)=-zz1/2.+2.*z2/3.-z3/24.-z4/6.+z5/24.
+ poidz(2)=1.-zz1/3.-5*z2/4.+5.*z3/12.+z4/4.-z5/12.
+ poidz(3)=zz1+2.*z2/3.-7.*z3/12.-z4/6.+z5/12.
+ poidz(4)=-zz1/4.-z2/24.+7.*z3/24.+z4/24.-z5/24.
+ poidz(5)=zz1/30.-z3/24.+z5/120.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,5
+ do d=0,5
+ do c=0,5
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l5
+
+
+ subroutine remaill_l5_x(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ip(c)+1,j,kvar)=remaille(ip(c)+1,j,kvar)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_x
+
+
+ subroutine remaill_l5_y(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(2),kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_y
+
+
+ subroutine remaill_l5_z(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posz(i)-zd)/dz)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posz(i) - real(ip(2),kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(1)=-xx1/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(2)=1.-xx1/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(3)=xx1+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(4)=-xx1/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(5)=xx1/30.-x3/24.+x5/120.
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_z
+
+
+
+
+
+
+
+ subroutine remaill_l6 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(-3:4) :: ip,jp,kp
+ real(kind=8),dimension(-3:4) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ real(kind=8) :: t1,t2,t3,t4,t5,t6
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+ jp(0) = floor((posy(i)-yb)/dy)
+ jp(-1) = jp(0) - 1
+ jp(-2) = jp(0) - 2
+ jp(-3) = jp(0) - 3
+ jp(1) = jp(0) + 1
+ jp(2) = jp(0) + 2
+ jp(3) = jp(0) + 3
+ jp(4) = jp(0) + 4
+
+ kp(0) = floor((posz(i)-zd)/dz)
+ kp(-1) = kp(0) - 1
+ kp(-2) = kp(0) - 2
+ kp(-3) = kp(0) - 3
+ kp(1) = kp(0) + 1
+ kp(2) = kp(0) + 2
+ kp(3) = kp(0) + 3
+ kp(4) = kp(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+ yy = (posy(i) - real(jp(0),kind=8)*dy-yb)/dy !relatif
+ zz = (posz(i) - real(kp(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=-3,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=-3,4
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+3.)
+ t6=(xx-1.)*xx
+
+ t1=t4*(xx-1.)
+ t2=t3*(xx+3.)
+
+ poidx(-3)=t1*xx*t3/720.
+ poidx(-2)=-t1*t5*(xx+1.)/120.
+ poidx(-1)=t1*t5*(xx+2.)/48.
+ poidx(0)=-t1*t2/36.
+ poidx(1)=t4*xx*t2/48.
+ poidx(2)=-(xx-3.)*t6*t2/120.
+ poidx(3)=(xx-2.)*t6*t2/720.
+ poidx(4)=0.
+ else
+
+ t3=xx*(xx+1.)
+ t4=(xx-3.)*(xx-2.)
+
+ t1=(xx-4.)*t4*(xx-1.)
+ t2=(xx-1.)*t3*(xx+2.)
+
+ poidx(-3)=0.
+ poidx(-2)=t1*t3/720.
+ poidx(-1)=-t1*xx*(xx+2.)/120.
+ poidx(0)=t1*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*t4*t3*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*t2/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*t2/120.
+ poidx(4)=t4*t2/720.
+ end if
+
+ if (yy<=0.5) then
+ t3=(yy+1.)*(yy+2.)
+ t4=(yy-3.)*(yy-2.)
+ t5=yy*(yy+3.)
+ t6=(yy-1.)*yy
+
+ t1=t4*(yy-1.)
+ t2=t3*(yy+3.)
+
+ poidy(-3)=t1*yy*t3/720.
+ poidy(-2)=-t1*t5*(yy+1.)/120.
+ poidy(-1)=t1*t5*(yy+2.)/48.
+ poidy(0)=-t1*t2/36.
+ poidy(1)=t4*yy*t2/48.
+ poidy(2)=-(yy-3.)*t6*t2/120.
+ poidy(3)=(yy-2.)*t6*t2/720.
+ poidy(4)=0.
+ else
+
+ t3=yy*(yy+1.)
+ t4=(yy-3.)*(yy-2.)
+
+ t1=(yy-4.)*t4*(yy-1.)
+ t2=(yy-1.)*t3*(yy+2.)
+
+ poidy(-3)=0.
+ poidy(-2)=t1*t3/720.
+ poidy(-1)=-t1*yy*(yy+2.)/120.
+ poidy(0)=t1*(yy+1.)*(yy+2.)/48.
+ poidy(1)=-(yy-4.)*t4*t3*(yy+2.)/36.
+ poidy(2)=(yy-4.)*(yy-3.)*t2/48.
+ poidy(3)=-(yy-4.)*(yy-2.)*t2/120.
+ poidy(4)=t4*t2/720.
+ end if
+
+ if (zz<=0.5) then
+ t3=(zz+1.)*(zz+2.)
+ t4=(zz-3.)*(zz-2.)
+ t5=zz*(zz+3.)
+ t6=(zz-1.)*zz
+
+ t1=t4*(zz-1.)
+ t2=t3*(zz+3.)
+
+ poidz(-3)=t1*zz*t3/720.
+ poidz(-2)=-t1*t5*(zz+1.)/120.
+ poidz(-1)=t1*t5*(zz+2.)/48.
+ poidz(0)=-t1*t2/36.
+ poidz(1)=t4*zz*t2/48.
+ poidz(2)=-(zz-3.)*t6*t2/120.
+ poidz(3)=(zz-2.)*t6*t2/720.
+ poidz(4)=0.
+ else
+
+ t3=zz*(zz+1.)
+ t4=(zz-3.)*(zz-2.)
+
+ t1=(zz-4.)*t4*(zz-1.)
+ t2=(zz-1.)*t3*(zz+2.)
+
+ poidz(-3)=0.
+ poidz(-2)=t1*t3/720.
+ poidz(-1)=-t1*zz*(zz+2.)/120.
+ poidz(0)=t1*(zz+1.)*(zz+2.)/48.
+ poidz(1)=-(zz-4.)*t4*t3*(zz+2.)/36.
+ poidz(2)=(zz-4.)*(zz-3.)*t2/48.
+ poidz(3)=-(zz-4.)*(zz-2.)*t2/120.
+ poidz(4)=t4*t2/720.
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-3,4
+ do d=-3,4
+ do c=-3,4
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l6
+
+
+
+ subroutine remaill_l8 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(-4:5) :: ip,jp,kp
+ real(kind=8),dimension(-4:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(-4) = ip(0) - 4
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+ ip(5) = ip(0) + 5
+
+ jp(0) = floor((posy(i)-yb)/dy)
+ jp(-1) = jp(0) - 1
+ jp(-2) = jp(0) - 2
+ jp(-3) = jp(0) - 3
+ jp(-4) = jp(0) - 4
+ jp(1) = jp(0) + 1
+ jp(2) = jp(0) + 2
+ jp(3) = jp(0) + 3
+ jp(4) = jp(0) + 4
+ jp(5) = jp(0) + 5
+
+ kp(0) = floor((posz(i)-zd)/dz)
+ kp(-1) = kp(0) - 1
+ kp(-2) = kp(0) - 2
+ kp(-3) = kp(0) - 3
+ kp(-4) = kp(0) - 4
+ kp(1) = kp(0) + 1
+ kp(2) = kp(0) + 2
+ kp(3) = kp(0) + 3
+ kp(4) = kp(0) + 4
+ kp(5) = kp(0) + 5
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+ yy = (posy(i) - real(jp(0),kind=8)*dy-yb)/dy !relatif
+ zz = (posz(i) - real(kp(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-4,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=-4,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=-4,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx+3.)*(xx+4.)
+ t5=(xx-4.)*(xx-3.)
+ t6=(xx-2.)*(xx-1.)*xx
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidx(-4)=t1*t3*(xx+3.)/(40320.)
+ poidx(-3)=-t1*t3*(xx+4.)/(5040.)
+ poidx(-2)=t1*(xx+1.)*t4/(1440.)
+ poidx(-1)=-t1*(xx+2.)*t4/(720.)
+ poidx(0)=t5*(xx-2.)*(xx-1.)*t2/(576.)
+ poidx(1)=-t5*(xx-2.)*xx*t2/(720.)
+ poidx(2)=t5*(xx-1.)*xx*t2/(1440.)
+ poidx(3)=-(xx-4.)*t6*t2/(5040.)
+ poidx(4)=(xx-3.)*t6*t2/(40320.)
+ poidx(5)=0.
+ else
+
+ t3=(xx-5.)*(xx-4.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+1.)
+ t6=(xx+2.)*(xx+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(xx-1.)
+ t8=(xx-1.)*t2
+
+ poidx(-4)=0.
+ poidx(-3)=t7*t5*(xx+2.)/(40320.)
+ poidx(-2)=-t7*t5*(xx+3.)/(5040.)
+ poidx(-1)=t7*xx*t6/(1440.)
+ poidx(0)=-t7*(xx+1.)*t6/(720.)
+ poidx(1)=t1*t2/(576.)
+ poidx(2)=-t3*(xx-3.)*t8/(720.)
+ poidx(3)=t3*(xx-2.)*t8/(1440.)
+ poidx(4)=-(xx-5.)*t4*t8/(5040.)
+ poidx(5)=(xx-4.)*t4*t8/(40320.)
+ end if
+ if (yy<=0.5) then
+
+ t3=(yy+1.)*(yy+2.)
+ t4=(yy+3.)*(yy+4.)
+ t5=(yy-4.)*(yy-3.)
+ t6=(yy-2.)*(yy-1.)*yy
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidy(-4)=t1*t3*(yy+3.)/(40320.)
+ poidy(-3)=-t1*t3*(yy+4.)/(5040.)
+ poidy(-2)=t1*(yy+1.)*t4/(1440.)
+ poidy(-1)=-t1*(yy+2.)*t4/(720.)
+ poidy(0)=t5*(yy-2.)*(yy-1.)*t2/(576.)
+ poidy(1)=-t5*(yy-2.)*yy*t2/(720.)
+ poidy(2)=t5*(yy-1.)*yy*t2/(1440.)
+ poidy(3)=-(yy-4.)*t6*t2/(5040.)
+ poidy(4)=(yy-3.)*t6*t2/(40320.)
+ poidy(5)=0.
+ else
+
+ t3=(yy-5.)*(yy-4.)
+ t4=(yy-3.)*(yy-2.)
+ t5=yy*(yy+1.)
+ t6=(yy+2.)*(yy+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(yy-1.)
+ t8=(yy-1.)*t2
+
+ poidy(-4)=0.
+ poidy(-3)=t7*t5*(yy+2.)/(40320.)
+ poidy(-2)=-t7*t5*(yy+3.)/(5040.)
+ poidy(-1)=t7*yy*t6/(1440.)
+ poidy(0)=-t7*(yy+1.)*t6/(720.)
+ poidy(1)=t1*t2/(576.)
+ poidy(2)=-t3*(yy-3.)*t8/(720.)
+ poidy(3)=t3*(yy-2.)*t8/(1440.)
+ poidy(4)=-(yy-5.)*t4*t8/(5040.)
+ poidy(5)=(yy-4.)*t4*t8/(40320.)
+ end if
+ if (zz<=0.5) then
+
+ t3=(zz+1.)*(zz+2.)
+ t4=(zz+3.)*(zz+4.)
+ t5=(zz-4.)*(zz-3.)
+ t6=(zz-2.)*(zz-1.)*zz
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidz(-4)=t1*t3*(zz+3.)/(40320.)
+ poidz(-3)=-t1*t3*(zz+4.)/(5040.)
+ poidz(-2)=t1*(zz+1.)*t4/(1440.)
+ poidz(-1)=-t1*(zz+2.)*t4/(720.)
+ poidz(0)=t5*(zz-2.)*(zz-1.)*t2/(576.)
+ poidz(1)=-t5*(zz-2.)*zz*t2/(720.)
+ poidz(2)=t5*(zz-1.)*zz*t2/(1440.)
+ poidz(3)=-(zz-4.)*t6*t2/(5040.)
+ poidz(4)=(zz-3.)*t6*t2/(40320.)
+ poidz(5)=0.
+ else
+
+ t3=(zz-5.)*(zz-4.)
+ t4=(zz-3.)*(zz-2.)
+ t5=zz*(zz+1.)
+ t6=(zz+2.)*(zz+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(zz-1.)
+ t8=(zz-1.)*t2
+
+ poidz(-4)=0.
+ poidz(-3)=t7*t5*(zz+2.)/(40320.)
+ poidz(-2)=-t7*t5*(zz+3.)/(5040.)
+ poidz(-1)=t7*zz*t6/(1440.)
+ poidz(0)=-t7*(zz+1.)*t6/(720.)
+ poidz(1)=t1*t2/(576.)
+ poidz(2)=-t3*(zz-3.)*t8/(720.)
+ poidz(3)=t3*(zz-2.)*t8/(1440.)
+ poidz(4)=-(zz-5.)*t4*t8/(5040.)
+ poidz(5)=(zz-4.)*t4*t8/(40320.)
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-4,5
+ do d=-4,5
+ do c=-4,5
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l8
+
+
+ subroutine remaill_l4_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-2:3) :: ip
+ real(kind=8),dimension(-2:3) :: poidx
+ real(kind=8) :: xx,x2,x3,x4
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+!!$ x2=xx**2
+!!$ x3=xx**3
+!!$ x4=xx**4
+!!$
+!!$ if (xx<=0.5) then
+!!$ poidx(-2)=(2.*xx-x2-2*x3+x4)/24.
+!!$ poidx(-1)=(-4.*xx+4.*x2+x3-x4)/6.
+!!$ poidx(0)=1.+(-5.*x2+x4)/4.
+!!$ poidx(1)=(4.*xx+4.*x2-x3-x4)/6.
+!!$ poidx(2)=(-2.*xx-x2+2*x3+x4)/24.
+!!$ poidx(3)=0.
+!!$ else
+!!$ poidx(-2)=0.
+!!$ poidx(-1)=(-6.*xx+11.*x2-6.*x3+x4)/24.
+!!$ poidx(0)=1.+(-5.*xx-5.*x2+5.*x3-x4)/6.
+!!$ poidx(1)=(6.*xx+x2-4.*x3+x4)/4.
+!!$ poidx(2)=(-3.*xx+x2+3.*x3-x4)/6.
+!!$ poidx(3)=(2.*xx-x2-2.*x3+x4)/24.
+!!$ end if
+
+ if (xx<=0.5) then
+ poidx(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poidx(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poidx(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ poidx(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poidx(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poidx(3)=0.
+ else
+ poidx(-2)=0.
+ poidx(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poidx(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poidx(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ poidx(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poidx(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,3
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l4_x
+
+
+
+ subroutine remaill_l4_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ivar,jvar,kvar
+ integer,dimension(-2:3) :: ip
+ real(kind=8),dimension(-2:3) :: poidx
+ real(kind=8) :: xx,x2,x3,x4
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+
+
+ do c=-2,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+
+ !calcul des poids
+ !----------------
+!!$ x2=xx**2
+!!$ x3=xx**3
+!!$ x4=xx**4
+!!$
+!!$ if (xx<=0.5) then
+!!$ poidx(-2)=(2.*xx-x2-2*x3+x4)/24.
+!!$ poidx(-1)=(-4.*xx+4.*x2+x3-x4)/6.
+!!$ poidx(0)=1.+(-5.*x2+x4)/4.
+!!$ poidx(1)=(4.*xx+4.*x2-x3-x4)/6.
+!!$ poidx(2)=(-2.*xx-x2+2*x3+x4)/24.
+!!$ poidx(3)=0.
+!!$ else
+!!$ poidx(-2)=0.
+!!$ poidx(-1)=(-6.*xx+11.*x2-6.*x3+x4)/24.
+!!$ poidx(0)=1.+(-5.*xx-5.*x2+5.*x3-x4)/6.
+!!$ poidx(1)=(6.*xx+x2-4.*x3+x4)/4.
+!!$ poidx(2)=(-3.*xx+x2+3.*x3-x4)/6.
+!!$ poidx(3)=(2.*xx-x2-2.*x3+x4)/24.
+!!$ end if
+
+ if (xx<=0.5) then
+ poidx(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poidx(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poidx(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ poidx(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poidx(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poidx(3)=0.
+ else
+ poidx(-2)=0.
+ poidx(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poidx(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poidx(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ poidx(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poidx(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-2,3
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l4_y
+
+ subroutine remaill_l4_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-2:3) :: ip
+ real(kind=8),dimension(-2:3) :: poidx
+ real(kind=8) :: xx,x2,x3,x4
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=-2,3
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+!!$ x2=xx**2
+!!$ x3=xx**3
+!!$ x4=xx**4
+!!$
+!!$ if (xx<=0.5) then
+!!$ poidx(-2)=(2.*xx-x2-2*x3+x4)/24.
+!!$ poidx(-1)=(-4.*xx+4.*x2+x3-x4)/6.
+!!$ poidx(0)=1.+(-5.*x2+x4)/4.
+!!$ poidx(1)=(4.*xx+4.*x2-x3-x4)/6.
+!!$ poidx(2)=(-2.*xx-x2+2*x3+x4)/24.
+!!$ poidx(3)=0.
+!!$ else
+!!$ poidx(-2)=0.
+!!$ poidx(-1)=(-6.*xx+11.*x2-6.*x3+x4)/24.
+!!$ poidx(0)=1.+(-5.*xx-5.*x2+5.*x3-x4)/6.
+!!$ poidx(1)=(6.*xx+x2-4.*x3+x4)/4.
+!!$ poidx(2)=(-3.*xx+x2+3.*x3-x4)/6.
+!!$ poidx(3)=(2.*xx-x2-2.*x3+x4)/24.
+!!$ end if
+
+ if (xx<=0.5) then
+ poidx(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poidx(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poidx(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ poidx(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poidx(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poidx(3)=0.
+ else
+ poidx(-2)=0.
+ poidx(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poidx(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poidx(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ poidx(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poidx(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-2,3
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l4_z
+
+ subroutine remaill_l6_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+3.)
+ t6=(xx-1.)*xx
+
+ t1=t4*(xx-1.)
+ t2=t3*(xx+3.)
+
+ poidx(-3)=t1*xx*t3/720.
+ poidx(-2)=-t1*t5*(xx+1.)/120.
+ poidx(-1)=t1*t5*(xx+2.)/48.
+ poidx(0)=-t1*t2/36.
+ poidx(1)=t4*xx*t2/48.
+ poidx(2)=-(xx-3.)*t6*t2/120.
+ poidx(3)=(xx-2.)*t6*t2/720.
+ poidx(4)=0.
+ else
+
+ t3=xx*(xx+1.)
+ t4=(xx-3.)*(xx-2.)
+
+ t1=(xx-4.)*t4*(xx-1.)
+ t2=(xx-1.)*t3*(xx+2.)
+
+ poidx(-3)=0.
+ poidx(-2)=t1*t3/720.
+ poidx(-1)=-t1*xx*(xx+2.)/120.
+ poidx(0)=t1*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*t4*t3*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*t2/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*t2/120.
+ poidx(4)=t4*t2/720.
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_x
+
+
+
+ subroutine remaill_l6_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+
+
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+3.)
+ t6=(xx-1.)*xx
+
+ t1=t4*(xx-1.)
+ t2=t3*(xx+3.)
+
+ poidx(-3)=t1*xx*t3/720.
+ poidx(-2)=-t1*t5*(xx+1.)/120.
+ poidx(-1)=t1*t5*(xx+2.)/48.
+ poidx(0)=-t1*t2/36.
+ poidx(1)=t4*xx*t2/48.
+ poidx(2)=-(xx-3.)*t6*t2/120.
+ poidx(3)=(xx-2.)*t6*t2/720.
+ poidx(4)=0.
+ else
+
+ t3=xx*(xx+1.)
+ t4=(xx-3.)*(xx-2.)
+
+ t1=(xx-4.)*t4*(xx-1.)
+ t2=(xx-1.)*t3*(xx+2.)
+
+ poidx(-3)=0.
+ poidx(-2)=t1*t3/720.
+ poidx(-1)=-t1*xx*(xx+2.)/120.
+ poidx(0)=t1*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*t4*t3*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*t2/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*t2/120.
+ poidx(4)=t4*t2/720.
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-3,4
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_y
+
+ subroutine remaill_l6_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=-3,4
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+3.)
+ t6=(xx-1.)*xx
+
+ t1=t4*(xx-1.)
+ t2=t3*(xx+3.)
+
+ poidx(-3)=t1*xx*t3/720.
+ poidx(-2)=-t1*t5*(xx+1.)/120.
+ poidx(-1)=t1*t5*(xx+2.)/48.
+ poidx(0)=-t1*t2/36.
+ poidx(1)=t4*xx*t2/48.
+ poidx(2)=-(xx-3.)*t6*t2/120.
+ poidx(3)=(xx-2.)*t6*t2/720.
+ poidx(4)=0.
+ else
+
+ t3=xx*(xx+1.)
+ t4=(xx-3.)*(xx-2.)
+
+ t1=(xx-4.)*t4*(xx-1.)
+ t2=(xx-1.)*t3*(xx+2.)
+
+ poidx(-3)=0.
+ poidx(-2)=t1*t3/720.
+ poidx(-1)=-t1*xx*(xx+2.)/120.
+ poidx(0)=t1*(xx+1.)*(xx+2.)/48.
+ poidx(1)=-(xx-4.)*t4*t3*(xx+2.)/36.
+ poidx(2)=(xx-4.)*(xx-3.)*t2/48.
+ poidx(3)=-(xx-4.)*(xx-2.)*t2/120.
+ poidx(4)=t4*t2/720.
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-3,4
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_z
+
+ subroutine remaill_l8_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-4:5) :: ip
+ real(kind=8),dimension(-4:5) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(-4) = ip(0) - 4
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+ ip(5) = ip(0) + 5
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-4,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx+3.)*(xx+4.)
+ t5=(xx-4.)*(xx-3.)
+ t6=(xx-2.)*(xx-1.)*xx
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidx(-4)=t1*t3*(xx+3.)/(40320.)
+ poidx(-3)=-t1*t3*(xx+4.)/(5040.)
+ poidx(-2)=t1*(xx+1.)*t4/(1440.)
+ poidx(-1)=-t1*(xx+2.)*t4/(720.)
+ poidx(0)=t5*(xx-2.)*(xx-1.)*t2/(576.)
+ poidx(1)=-t5*(xx-2.)*xx*t2/(720.)
+ poidx(2)=t5*(xx-1.)*xx*t2/(1440.)
+ poidx(3)=-(xx-4.)*t6*t2/(5040.)
+ poidx(4)=(xx-3.)*t6*t2/(40320.)
+ poidx(5)=0.
+ else
+
+ t3=(xx-5.)*(xx-4.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+1.)
+ t6=(xx+2.)*(xx+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(xx-1.)
+ t8=(xx-1.)*t2
+
+ poidx(-4)=0.
+ poidx(-3)=t7*t5*(xx+2.)/(40320.)
+ poidx(-2)=-t7*t5*(xx+3.)/(5040.)
+ poidx(-1)=t7*xx*t6/(1440.)
+ poidx(0)=-t7*(xx+1.)*t6/(720.)
+ poidx(1)=t1*t2/(576.)
+ poidx(2)=-t3*(xx-3.)*t8/(720.)
+ poidx(3)=t3*(xx-2.)*t8/(1440.)
+ poidx(4)=-(xx-5.)*t4*t8/(5040.)
+ poidx(5)=(xx-4.)*t4*t8/(40320.)
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-4,5
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l8_x
+
+subroutine remaill_l8_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-4:5) :: ip
+ real(kind=8),dimension(-4:5) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(-4) = ip(0) - 4
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+ ip(5) = ip(0) + 5
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-4,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx+3.)*(xx+4.)
+ t5=(xx-4.)*(xx-3.)
+ t6=(xx-2.)*(xx-1.)*xx
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidx(-4)=t1*t3*(xx+3.)/(40320.)
+ poidx(-3)=-t1*t3*(xx+4.)/(5040.)
+ poidx(-2)=t1*(xx+1.)*t4/(1440.)
+ poidx(-1)=-t1*(xx+2.)*t4/(720.)
+ poidx(0)=t5*(xx-2.)*(xx-1.)*t2/(576.)
+ poidx(1)=-t5*(xx-2.)*xx*t2/(720.)
+ poidx(2)=t5*(xx-1.)*xx*t2/(1440.)
+ poidx(3)=-(xx-4.)*t6*t2/(5040.)
+ poidx(4)=(xx-3.)*t6*t2/(40320.)
+ poidx(5)=0.
+ else
+
+ t3=(xx-5.)*(xx-4.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+1.)
+ t6=(xx+2.)*(xx+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(xx-1.)
+ t8=(xx-1.)*t2
+
+ poidx(-4)=0.
+ poidx(-3)=t7*t5*(xx+2.)/(40320.)
+ poidx(-2)=-t7*t5*(xx+3.)/(5040.)
+ poidx(-1)=t7*xx*t6/(1440.)
+ poidx(0)=-t7*(xx+1.)*t6/(720.)
+ poidx(1)=t1*t2/(576.)
+ poidx(2)=-t3*(xx-3.)*t8/(720.)
+ poidx(3)=t3*(xx-2.)*t8/(1440.)
+ poidx(4)=-(xx-5.)*t4*t8/(5040.)
+ poidx(5)=(xx-4.)*t4*t8/(40320.)
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-4,5
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l8_y
+
+subroutine remaill_l8_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-4:5) :: ip
+ real(kind=8),dimension(-4:5) :: poidx
+ real(kind=8) :: xx
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(-4) = ip(0) - 4
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+ ip(5) = ip(0) + 5
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-4,5
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+
+ t3=(xx+1.)*(xx+2.)
+ t4=(xx+3.)*(xx+4.)
+ t5=(xx-4.)*(xx-3.)
+ t6=(xx-2.)*(xx-1.)*xx
+
+ t1=t5*t6
+ t2=t3*t4
+
+ poidx(-4)=t1*t3*(xx+3.)/(40320.)
+ poidx(-3)=-t1*t3*(xx+4.)/(5040.)
+ poidx(-2)=t1*(xx+1.)*t4/(1440.)
+ poidx(-1)=-t1*(xx+2.)*t4/(720.)
+ poidx(0)=t5*(xx-2.)*(xx-1.)*t2/(576.)
+ poidx(1)=-t5*(xx-2.)*xx*t2/(720.)
+ poidx(2)=t5*(xx-1.)*xx*t2/(1440.)
+ poidx(3)=-(xx-4.)*t6*t2/(5040.)
+ poidx(4)=(xx-3.)*t6*t2/(40320.)
+ poidx(5)=0.
+ else
+
+ t3=(xx-5.)*(xx-4.)
+ t4=(xx-3.)*(xx-2.)
+ t5=xx*(xx+1.)
+ t6=(xx+2.)*(xx+3.)
+
+ t1=t3*t4
+ t2=t5*t6
+
+ t7=t1*(xx-1.)
+ t8=(xx-1.)*t2
+
+ poidx(-4)=0.
+ poidx(-3)=t7*t5*(xx+2.)/(40320.)
+ poidx(-2)=-t7*t5*(xx+3.)/(5040.)
+ poidx(-1)=t7*xx*t6/(1440.)
+ poidx(0)=-t7*(xx+1.)*t6/(720.)
+ poidx(1)=t1*t2/(576.)
+ poidx(2)=-t3*(xx-3.)*t8/(720.)
+ poidx(3)=t3*(xx-2.)*t8/(1440.)
+ poidx(4)=-(xx-5.)*t4*t8/(5040.)
+ poidx(5)=(xx-4.)*t4*t8/(40320.)
+ end if
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-4,5
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l8_z
+
+
+ subroutine remaill_l2_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-1,2
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l2_x
+
+
+
+ subroutine remaill_l2_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+
+
+ do c=-1,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-1,2
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l2_y
+
+ subroutine remaill_l2_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-1:2) :: ip
+ real(kind=8),dimension(-1:2) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=-1,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5) then
+ poidx(-1)=0.5*xx*(xx-1.)
+ poidx(0)=1.-xx**2
+ poidx(1)=0.5*xx*(1.+xx)
+ poidx(2)=0.
+ else
+ poidx(-1)=0.
+ poidx(0)=0.5*(1.-xx)*(2.-xx)
+ poidx(1)=2.*xx-xx**2
+ poidx(2)=0.5*(xx-1.)*xx
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-1,2
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l2_z
+
+
+
+
+ subroutine remaill_l2_bloc_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,k,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ case(2)
+ poids(0)=1.-0.5*xx*(1.+xx)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ case(4)
+ poids(-2)=0.5*xx*(1.+xx)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ case(5)
+ poids(-1)=-0.5*xx+0.5*xx**2
+ poids(0)=1.-poids(-1)
+
+ end select
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=0.5*xx*(1.+xx)
+ else
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ end if
+ case(1)
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1)
+ case(3)
+ poids(1)=3.*0.5*xx-0.5*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_x
+
+
+ subroutine remaill_l2_bloc_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ case(2)
+ poids(0)=1.-0.5*xx*(1.+xx)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ case(4)
+ poids(-2)=0.5*xx*(1.+xx)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ case(5)
+ poids(-1)=-0.5*xx+0.5*xx**2
+ poids(0)=1.-poids(-1)
+
+ end select
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=0.5*xx*(1.+xx)
+ else
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ end if
+ case(1)
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1)
+ case(3)
+ poids(1)=3.*0.5*xx-0.5*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_y
+
+ subroutine remaill_l2_bloc_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ case(2)
+ poids(0)=1.-0.5*xx*(1.+xx)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ case(4)
+ poids(-2)=0.5*xx*(1.+xx)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ case(5)
+ poids(-1)=-0.5*xx+0.5*xx**2
+ poids(0)=1.-poids(-1)
+
+ end select
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=0.5*xx*(1.+xx)
+ else
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ end if
+ case(1)
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1)
+ case(3)
+ poids(1)=3.*0.5*xx-0.5*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_z
+
+
+
+ subroutine remaill_l2_bloc_x_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,k,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.) !alpha
+ poids(0)=1.-xx**2 !beta
+ poids(1)=0.5*xx*(1.+xx) !gamma
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx) !alpha'
+ poids(1)=2.*xx-xx**2 !beta'
+ poids(2)=0.5*(xx-1.)*xx !gamma'
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ poids(1)=1.-poids(0)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-poids(-1)
+ case(4)
+ poids(0)=-0.5*xx*(xx+1.)+1.
+ poids(1)=1.-poids(0)
+ case(5)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1.)
+ case(6)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ case(7)
+ poids(-2)=0.5*xx*(xx+1)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_x_v2
+
+
+ subroutine remaill_l2_bloc_y_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.) !alpha
+ poids(0)=1.-xx**2 !beta
+ poids(1)=0.5*xx*(1.+xx) !gamma
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx) !alpha'
+ poids(1)=2.*xx-xx**2 !beta'
+ poids(2)=0.5*(xx-1.)*xx !gamma'
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ poids(1)=1.-poids(0)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-poids(-1)
+ case(4)
+ poids(0)=-0.5*xx*(xx+1.)+1.
+ poids(1)=1.-poids(0)
+ case(5)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1.)
+ case(6)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ case(7)
+ poids(-2)=0.5*xx*(xx+1)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_y_v2
+
+ subroutine remaill_l2_bloc_z_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ poids(-1)=0.5*xx*(xx-1.) !alpha
+ poids(0)=1.-xx**2 !beta
+ poids(1)=0.5*xx*(1.+xx) !gamma
+ else
+ poids(0)=0.5*(1.-xx)*(2.-xx) !alpha'
+ poids(1)=2.*xx-xx**2 !beta'
+ poids(2)=0.5*(xx-1.)*xx !gamma'
+ end if
+ case(1)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ case(2)
+ poids(0)=0.5*(1.-xx)*(2.-xx)
+ poids(1)=1.-poids(0)
+ case(3)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-poids(-1)
+ case(4)
+ poids(0)=-0.5*xx*(xx+1.)+1.
+ poids(1)=1.-poids(0)
+ case(5)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx**2
+ poids(1)=xx
+ poids(2)=0.5*xx*(xx-1.)
+ case(6)
+ poids(-1)=0.5*xx*(xx-1.)
+ poids(0)=1.-xx
+ poids(1)=2.*xx-xx**2
+ poids(2)=0.5*(xx-1.)*xx
+ case(7)
+ poids(-2)=0.5*xx*(xx+1)
+ poids(-1)=-xx
+ poids(0)=1.-xx**2
+ poids(1)=0.5*xx*(1.+xx)
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_z_v2
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ subroutine remaill_l4_bloc_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per,k
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+ else
+ t1=(xx-1.)*(xx-2.)*(xx-3.)
+ poids(-1)=t1*xx/24.
+ poids(0)=-t1*(xx+1.)/6.
+ end if
+ case(1)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+
+ case(2)
+ t1=(xx-1.)*(xx-2.)/12.
+ poids(-1)=t1*xx*(xx-3)/2.
+ poids(0)=t1*(xx+6.)*(xx+1.)
+ case(3)
+ t1=0.5*(xx-1.)*(xx-2.)
+ poids(-2)=t1*xx/12.*(xx+1.)
+ poids(-1)=-t1*xx/3.*(xx+2.)
+ poids(0)=t1*(xx+1.)
+ case(4)
+ t2=(xx**2-1.)
+ t1=xx*(xx+2.)*0.5
+ poids(-3)=t2*t1/12.
+ poids(-2)=-t2*xx/6.*(xx+3.)
+ poids(-1)=t1*(xx-1.)
+ poids(0)=t2*(xx**2-4.)/4.
+ case(5)
+ t1=(xx-2.)*(xx-1.)/4.
+ poids(-1)=-t1*xx/6.*(3*xx+7.)
+ poids(0)=t1*(xx+2.)*(xx+1.)
+ case(6)
+ t1= (xx-1.)*(xx-2.)/6.
+ t2=t1*(xx+1.)
+ poids(-2)=t2*xx/4.
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.)
+ case(7)
+ t1=(xx-1.)*(xx+2.)
+ t2=xx*(xx+1)/6.
+ poids(-3)=t1*t2/4.
+ poids(-2)=-t2*(xx-1.)
+ poids(-1)=-xx*t1/6.*(xx-2.)
+ poids(0)=t1*(xx-2.)/4.*(xx+1.)
+ case(8)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=(xx-6.)*(xx+2.)*(xx**2-1.)/12.
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ else
+ t1=xx*(xx+1.)*(xx-3.)
+ poids(1)=t1*(xx-2.)/4.
+ poids(2)=-t1*(xx-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ end if
+ case(1)
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ case(2)
+ t1=xx*(xx+1.)*0.5
+ t2=t1*(xx-1.)
+ poids(1)=-t1*(xx-2.)
+ poids(2)=-t2/3.*(xx-3.)
+ poids(3)=t2*(xx-2.)/12.
+ case(3)
+ t1=xx*(xx+1.)/12.
+ poids(1)=t1*(xx-2.)*(xx-7.)
+ poids(2)=t1*(xx+2.)*(xx-1.)/2.
+ case(4)
+ t1=xx*(xx+1.)
+ t2=t1*(xx-1.)/6.
+ poids(1)=-t1*(xx+2.)*(xx-2.)/6.
+ poids(2)=t2
+ poids(3)=t2*(xx-2.)/4.
+ case(5)
+ poids(1)=-xx/24.*(3.*xx-7.)*(xx+2.)*(xx+1.)
+ case(6)
+ t1=xx*(xx+1.)/4.
+ poids(1)=t1*(xx-3.)*(xx-2.)
+ poids(2)=-t1*(3.*xx-10.)*(xx-1.)/6.
+ case(7)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_x
+
+
+ subroutine remaill_l4_bloc_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+ else
+ t1=(xx-1.)*(xx-2.)*(xx-3.)
+ poids(-1)=t1*xx/24.
+ poids(0)=-t1*(xx+1.)/6.
+ end if
+ case(1)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+
+ case(2)
+ t1=(xx-1.)*(xx-2.)/12.
+ poids(-1)=t1*xx*(xx-3)/2.
+ poids(0)=t1*(xx+6.)*(xx+1.)
+ case(3)
+ t1=0.5*(xx-1.)*(xx-2.)
+ poids(-2)=t1*xx/12.*(xx+1.)
+ poids(-1)=-t1*xx/3.*(xx+2.)
+ poids(0)=t1*(xx+1.)
+ case(4)
+ t2=(xx**2-1.)
+ t1=xx*(xx+2.)*0.5
+ poids(-3)=t2*t1/12.
+ poids(-2)=-t2*xx/6.*(xx+3.)
+ poids(-1)=t1*(xx-1.)
+ poids(0)=t2*(xx**2-4.)/4.
+ case(5)
+ t1=(xx-2.)*(xx-1.)/4.
+ poids(-1)=-t1*xx/6.*(3*xx+7.)
+ poids(0)=t1*(xx+2.)*(xx+1.)
+ case(6)
+ t1= (xx-1.)*(xx-2.)/6.
+ t2=t1*(xx+1.)
+ poids(-2)=t2*xx/4.
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.)
+ case(7)
+ t1=(xx-1.)*(xx+2.)
+ t2=xx*(xx+1)/6.
+ poids(-3)=t1*t2/4.
+ poids(-2)=-t2*(xx-1.)
+ poids(-1)=-xx*t1/6.*(xx-2.)
+ poids(0)=t1*(xx-2.)/4.*(xx+1.)
+ case(8)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=(xx-6.)*(xx+2.)*(xx**2-1.)/12.
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ else
+ t1=xx*(xx+1.)*(xx-3.)
+ poids(1)=t1*(xx-2.)/4.
+ poids(2)=-t1*(xx-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ end if
+ case(1)
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ case(2)
+ t1=xx*(xx+1.)*0.5
+ t2=t1*(xx-1.)
+ poids(1)=-t1*(xx-2.)
+ poids(2)=-t2/3.*(xx-3.)
+ poids(3)=t2*(xx-2.)/12.
+ case(3)
+ t1=xx*(xx+1.)/12.
+ poids(1)=t1*(xx-2.)*(xx-7.)
+ poids(2)=t1*(xx+2.)*(xx-1.)/2.
+ case(4)
+ t1=xx*(xx+1.)
+ t2=t1*(xx-1.)/6.
+ poids(1)=-t1*(xx+2.)*(xx-2.)/6.
+ poids(2)=t2
+ poids(3)=t2*(xx-2.)/4.
+ case(5)
+ poids(1)=-xx/24.*(3.*xx-7.)*(xx+2.)*(xx+1.)
+ case(6)
+ t1=xx*(xx+1.)/4.
+ poids(1)=t1*(xx-3.)*(xx-2.)
+ poids(2)=-t1*(3.*xx-10.)*(xx-1.)/6.
+ case(7)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_y
+
+
+ subroutine remaill_l4_bloc_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poidss
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+ else
+ t1=(xx-1.)*(xx-2.)*(xx-3.)
+ poids(-1)=t1*xx/24.
+ poids(0)=-t1*(xx+1.)/6.
+ end if
+ case(1)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=t2/4.*(xx**2-1.)
+
+ case(2)
+ t1=(xx-1.)*(xx-2.)/12.
+ poids(-1)=t1*xx*(xx-3)/2.
+ poids(0)=t1*(xx+6.)*(xx+1.)
+ case(3)
+ t1=0.5*(xx-1.)*(xx-2.)
+ poids(-2)=t1*xx/12.*(xx+1.)
+ poids(-1)=-t1*xx/3.*(xx+2.)
+ poids(0)=t1*(xx+1.)
+ case(4)
+ t2=(xx**2-1.)
+ t1=xx*(xx+2.)*0.5
+ poids(-3)=t2*t1/12.
+ poids(-2)=-t2*xx/6.*(xx+3.)
+ poids(-1)=t1*(xx-1.)
+ poids(0)=t2*(xx**2-4.)/4.
+ case(5)
+ t1=(xx-2.)*(xx-1.)/4.
+ poids(-1)=-t1*xx/6.*(3*xx+7.)
+ poids(0)=t1*(xx+2.)*(xx+1.)
+ case(6)
+ t1= (xx-1.)*(xx-2.)/6.
+ t2=t1*(xx+1.)
+ poids(-2)=t2*xx/4.
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.)
+ case(7)
+ t1=(xx-1.)*(xx+2.)
+ t2=xx*(xx+1)/6.
+ poids(-3)=t1*t2/4.
+ poids(-2)=-t2*(xx-1.)
+ poids(-1)=-xx*t1/6.*(xx-2.)
+ poids(0)=t1*(xx-2.)/4.*(xx+1.)
+ case(8)
+ t1=xx*(xx-1.)
+ t2=xx**2-4.
+ poids(-2)=t1/24.*(xx-2.)*(xx+1.)
+ poids(-1)=-t1/6.*t2
+ poids(0)=(xx-6.)*(xx+2.)*(xx**2-1.)/12.
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5) then
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ else
+ t1=xx*(xx+1.)*(xx-3.)
+ poids(1)=t1*(xx-2.)/4.
+ poids(2)=-t1*(xx-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ end if
+ case(1)
+ t1=xx*(xx+1.)*(xx+2.)
+ poids(1)=-t1*(xx-2.)/6.
+ poids(2)=t1*(xx-1.)/24.
+ case(2)
+ t1=xx*(xx+1.)*0.5
+ t2=t1*(xx-1.)
+ poids(1)=-t1*(xx-2.)
+ poids(2)=-t2/3.*(xx-3.)
+ poids(3)=t2*(xx-2.)/12.
+ case(3)
+ t1=xx*(xx+1.)/12.
+ poids(1)=t1*(xx-2.)*(xx-7.)
+ poids(2)=t1*(xx+2.)*(xx-1.)/2.
+ case(4)
+ t1=xx*(xx+1.)
+ t2=t1*(xx-1.)/6.
+ poids(1)=-t1*(xx+2.)*(xx-2.)/6.
+ poids(2)=t2
+ poids(3)=t2*(xx-2.)/4.
+ case(5)
+ poids(1)=-xx/24.*(3.*xx-7.)*(xx+2.)*(xx+1.)
+ case(6)
+ t1=xx*(xx+1.)/4.
+ poids(1)=t1*(xx-3.)*(xx-2.)
+ poids(2)=-t1*(3.*xx-10.)*(xx-1.)/6.
+ case(7)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_z
+
+
+ subroutine remaill_l4_bloc_x_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per,k
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+ select case (blocg(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx**4/12.-2.*xx**3/3.+5.*xx**2/12.+7.*xx/6.
+ case(3)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=1.+xx**4/12.-13.*xx**2/12.-xx**3/3.+xx/3.
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=xx*(xx-1.)*(xx-2.)*(xx-3.)/24.
+ poids(0)=xx**4/12.+xx**3/3.-13.*xx**2/12.-xx/3.+1.
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=1.-xx**4/8.+7.*xx**3/12.-3.*xx**2/8.-13.*xx/12.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=-xx**4/8.+xx**3/12.+5.*xx**2/8.-7.*xx/12.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(7)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=0.5*xx**3-xx**2-0.5*xx+1.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(8)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=-xx*(xx+3.)*(xx**2-1.)/6.
+ poids(-1)=0.5*xx**3+0.5*xx**2-xx
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(9)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx**3/6.+0.5*xx**2-xx/3.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(10)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=xx*(1.-xx**2)/6.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=-xx**4/8.+5.*xx**3/12.+xx**2/8.-5.*xx/12.
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=-xx**4/8.-xx**3/12.+5.*xx**2/8.+7.*xx/12.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=xx*(xx+2.)*(xx**2-1.)/24.
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6.
+ poids(3)=xx**3/6.-0.5*xx*2+xx/3.
+ poids(4)=xx*(xx-1)*(xx-2.)*(xx-3.)/24.
+ case(7)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6.
+ poids(2)=xx*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ case(8)
+ poids(1)=-0.5*xx**3+0.5*xx**2+xx
+ poids(2)=-xx*(xx-3)*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ end select
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_x_v2
+
+
+ subroutine remaill_l4_bloc_y_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+ select case (blocg(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx**4/12.-2.*xx**3/3.+5.*xx**2/12.+7.*xx/6.
+ case(3)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=1.+xx**4/12.-13.*xx**2/12.-xx**3/3.+xx/3.
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=xx*(xx-1.)*(xx-2.)*(xx-3.)/24.
+ poids(0)=xx**4/12.+xx**3/3.-13.*xx**2/12.-xx/3.+1.
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=1.-xx**4/8.+7.*xx**3/12.-3.*xx**2/8.-13.*xx/12.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=-xx**4/8.+xx**3/12.+5.*xx**2/8.-7.*xx/12.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(7)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=0.5*xx**3-xx**2-0.5*xx+1.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(8)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=-xx*(xx+3.)*(xx**2-1.)/6.
+ poids(-1)=0.5*xx**3+0.5*xx**2-xx
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(9)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx**3/6.+0.5*xx**2-xx/3.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(10)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=xx*(1.-xx**2)/6.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=-xx**4/8.+5.*xx**3/12.+xx**2/8.-5.*xx/12.
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=-xx**4/8.-xx**3/12.+5.*xx**2/8.+7.*xx/12.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=xx*(xx+2.)*(xx**2-1.)/24.
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6.
+ poids(3)=xx**3/6.-0.5*xx*2+xx/3.
+ poids(4)=xx*(xx-1)*(xx-2.)*(xx-3.)/24.
+ case(7)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6.
+ poids(2)=xx*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ case(8)
+ poids(1)=-0.5*xx**3+0.5*xx**2+xx
+ poids(2)=-xx*(xx-3)*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_y_v2
+
+
+ subroutine remaill_l4_bloc_z_v2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.
+
+ do i=1,npart
+
+ poids=0.
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ do c=-3,4
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poidss
+ !----------------
+ select case (blocg(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ else
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24. !a'
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6. !b'
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4. !c'
+ end if
+ case(1)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24. !a
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6. !b
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4. !c
+ case(2)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=(xx-1.)*(xx-2.)*(xx-3.)*xx/24.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx**4/12.-2.*xx**3/3.+5.*xx**2/12.+7.*xx/6.
+ case(3)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-1.)*(xx-2.)*(xx+1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=1.+xx**4/12.-13.*xx**2/12.-xx**3/3.+xx/3.
+ case(4)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=xx*(xx-1.)*(xx-2.)*(xx-3.)/24.
+ poids(0)=xx**4/12.+xx**3/3.-13.*xx**2/12.-xx/3.+1.
+ case(5)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=0.
+ poids(0)=1.-xx**4/8.+7.*xx**3/12.-3.*xx**2/8.-13.*xx/12.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(6)
+ poids(-3)=0.
+ poids(-2)=0.
+ poids(-1)=-xx**4/8.+xx**3/12.+5.*xx**2/8.-7.*xx/12.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(7)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=0.5*xx**3-xx**2-0.5*xx+1.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(8)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=-xx*(xx+3.)*(xx**2-1.)/6.
+ poids(-1)=0.5*xx**3+0.5*xx**2-xx
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ case(9)
+ poids(-3)=0.
+ poids(-2)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(-1)=-xx**3/6.+0.5*xx**2-xx/3.
+ poids(0)=-(xx-1.)*(xx-2.)*(xx-3.)*(xx+1.)/6.
+ poids(1)=xx*(xx+1.)*(xx-3.)*(xx-2.)/4.
+ case(10)
+ poids(-3)=(xx+2.)*xx*(xx**2-1.)/24.
+ poids(-2)=xx*(1.-xx**2)/6.
+ poids(-1)=-xx*(xx-1.)*(xx**2-4.)/6.
+ poids(0)=(xx**2-4.)*(xx**2-1.)/4.
+ end select
+
+ select case (blocd(i))
+ case(0)
+ if (xx<=0.5) then
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ else
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6. !d'
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24. !e'
+ poids(4)=0.
+ end if
+ case(1)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6. !d
+ poids(2)=xx*(xx+1.)*(xx+2.)*(xx-1.)/24. !e
+ poids(3)=0.
+ poids(4)=0.
+ case(2)
+ poids(2)=-xx**4/8.+5.*xx**3/12.+xx**2/8.-5.*xx/12.
+ poids(3)=0.
+ poids(4)=0.
+ case(3)
+ poids(1)=-xx**4/8.-xx**3/12.+5.*xx**2/8.+7.*xx/12.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(4)
+ poids(2)=xx*(xx+2.)*(xx**2-1.)/24.
+ poids(3)=0.
+ poids(4)=0.
+ case(5)
+ poids(1)=xx*(xx+1.)*(xx+2.)*(xx+3.)/24.
+ poids(2)=0.
+ poids(3)=0.
+ poids(4)=0.
+ case(6)
+ poids(2)=-xx*(xx+1.)*(xx-3.)*(xx-1.)/6.
+ poids(3)=xx**3/6.-0.5*xx*2+xx/3.
+ poids(4)=xx*(xx-1)*(xx-2.)*(xx-3.)/24.
+ case(7)
+ poids(1)=-xx*(xx+1.)*(xx+2.)*(xx-2.)/6.
+ poids(2)=xx*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ case(8)
+ poids(1)=-0.5*xx**3+0.5*xx**2+xx
+ poids(2)=-xx*(xx-3)*(xx**2-1.)/6.
+ poids(3)=xx*(xx-2.)*(xx**2-1.)/24.
+ poids(4)=0.
+ end select
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_z_v2
+
+
+
+ subroutine limit_l2_bloc_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poidx
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2) :: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1) :: phi
+
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ poidx=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+ else
+
+ poidx(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poidx(1)=cb(xx-1.,1,1)
+ poidx(2)=cc(xx-1.,1)
+ else
+ poidx(1)=cb(xx-1.,1,0)
+ poidx(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+ case(1)
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+
+ case(2)
+ poidx(0)=ca(xx-1.,1)
+ poidx(1)=cb(xx-1.,1,0)+cc(xx-1.,0)
+ case(3)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)+cc(xx,0)
+ case(4)
+ poidx(0)=ca(xx,1)+cb(xx,1,0)
+ poidx(1)=cc(xx,0)
+
+
+
+ case(5)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)-cc(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+ case(6)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=ca(xx-1.,1)-ca(xx,0)
+ poidx(1)=cb(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+
+ case(7)
+ poidx(-2)=ca(xx+1.,0)
+ poidx(-1)=ca(xx,0)-ca(xx+1.,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)
+ end select
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8. ! +1./6.
+ case(0)
+ c=-x**2+1. -2./8. !-2./6.
+ case(1)
+ c=0.5*x*(1.+x) +1./8. ! +1./6.
+ end select
+
+ end function coeff_tscg
+
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posx(mod(ipart-1+vois+npart,npart)+1) - real( floor((posx(mod(ipart-1+vois+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posx(mod(i-1+ib+npart,npart)+1) - real( floor((posx(mod(i-1+ib+npart,npart)+1)-xg)/dx) ,kind=8)*dx-xg)/dx
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+
+ end subroutine limit_l2_bloc_x
+
+
+
+
+ subroutine limit_l2_bloc_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poidx
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2) :: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1) :: phi
+
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ poidx=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+ else
+
+ poidx(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poidx(1)=cb(xx-1.,1,1)
+ poidx(2)=cc(xx-1.,1)
+ else
+ poidx(1)=cb(xx-1.,1,0)
+ poidx(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+ case(1)
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+
+ case(2)
+ poidx(0)=ca(xx-1.,1)
+ poidx(1)=cb(xx-1.,1,0)+cc(xx-1.,0)
+ case(3)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)+cc(xx,0)
+ case(4)
+ poidx(0)=ca(xx,1)+cb(xx,1,0)
+ poidx(1)=cc(xx,0)
+
+
+
+ case(5)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)-cc(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+ case(6)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=ca(xx-1.,1)-ca(xx,0)
+ poidx(1)=cb(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+
+ case(7)
+ poidx(-2)=ca(xx+1.,0)
+ poidx(-1)=ca(xx,0)-ca(xx+1.,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)
+ end select
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8.
+ case(0)
+ c=-x**2+1. -2./8.
+ case(1)
+ c=0.5*x*(1.+x) +1./8.
+ end select
+
+ end function coeff_tscg
+
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posy(mod(ipart-1+vois+npart,npart)+1) - real( floor((posy(mod(ipart-1+vois+npart,npart)+1)-yb)/dy) ,kind=8)*dy-yb)/dy
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posy(mod(i-1+ib+npart,npart)+1) - real( floor((posy(mod(i-1+ib+npart,npart)+1)-yb)/dy) ,kind=8)*dy-yb)/dy
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+
+ end subroutine limit_l2_bloc_y
+
+
+
+
+ subroutine limit_l2_bloc_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar,j,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poidx
+ real(kind=8) :: xx,tmp_pos
+ real(kind=8),dimension(0:2) :: phi_mdemi,phi_pdemi
+ real(kind=8),dimension(0:1) :: phi
+
+
+ remaille=0.
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ jvar=nint((posy(i)-yb)/dy)+1
+
+ poidx=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul du limiteur pour cas de bloc centre avec xx>0.5
+ !--------------------------------------------------------
+ call calcul_phi_tvd(phi,1)
+ phi_mdemi(1)=phi(0)
+ phi_pdemi(1)=phi(1)
+
+ !les autres cas ...
+ !---------------------
+ call calcul_phi_tvd(phi,0)
+ phi_mdemi(0)=phi(0)
+ phi_pdemi(0)=phi(1)
+
+ phi_mdemi(2)=0.
+ phi_pdemi(2)=0.
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5) then
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+ else
+
+ poidx(0)=ca(xx-1.,1)
+ if (test (i,1) ) then
+ poidx(1)=cb(xx-1.,1,1)
+ poidx(2)=cc(xx-1.,1)
+ else
+ poidx(1)=cb(xx-1.,1,0)
+ poidx(2)=cc(xx-1.,0)
+ end if
+
+ end if
+
+ case(1)
+
+ poidx(-1)=ca(xx,0)
+ if (test (i,1) ) then
+ poidx(0)=cb(xx,0,1)
+ poidx(1)=cc(xx,1)
+ else
+ poidx(0)=cb(xx,0,0)
+ poidx(1)=cc(xx,0)
+ end if
+
+
+ case(2)
+ poidx(0)=ca(xx-1.,1)
+ poidx(1)=cb(xx-1.,1,0)+cc(xx-1.,0)
+ case(3)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)+cc(xx,0)
+ case(4)
+ poidx(0)=ca(xx,1)+cb(xx,1,0)
+ poidx(1)=cc(xx,0)
+
+
+
+ case(5)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)-cc(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+ case(6)
+ poidx(-1)=ca(xx,0)
+ poidx(0)=ca(xx-1.,1)-ca(xx,0)
+ poidx(1)=cb(xx-1.,1)
+ poidx(2)=cc(xx-1.,1)
+
+
+ case(7)
+ poidx(-2)=ca(xx+1.,0)
+ poidx(-1)=ca(xx,0)-ca(xx+1.,0)
+ poidx(0)=cb(xx,0)
+ poidx(1)=cc(xx,0)
+ end select
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ contains
+
+ function coeff_l2g (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.)
+ case(0)
+ c=1.-x**2
+ case(1)
+ c=0.5*x*(1.+x)
+ end select
+
+ end function coeff_l2g
+
+ function coeff_tscg (num,x) result(c)
+ implicit none
+ integer,intent(in) :: num
+ real(kind=8),intent(in) :: x
+ real(kind=8) :: c
+
+ select case(num)
+ case(-1)
+ c=0.5*x*(x-1.) +1./8.
+ case(0)
+ c=-x**2+1. -2./8.
+ case(1)
+ c=0.5*x*(1.+x) +1./8.
+ end select
+
+ end function coeff_tscg
+
+ function ca(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: ca
+
+ ca=coeff_tscg(-1,x)+phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+
+ end function ca
+
+ function cb(x,num,num2)
+ integer :: num
+ real(kind=8) :: x
+ integer,optional :: num2
+ real(kind=8) :: cb
+
+ if (present (num2)) then
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num2)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ else
+ cb=1.-(coeff_tscg(-1,x)+coeff_tscg(1,x))-phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))-phi_mdemi(num)*(coeff_l2g(-1,x)-coeff_tscg(-1,x))
+ end if
+
+ end function cb
+
+ function cc(x,num)
+ integer :: num
+ real(kind=8) :: x
+ real(kind=8) :: cc
+
+ cc=coeff_tscg(1,x)+phi_pdemi(num)*(coeff_l2g(1,x)-coeff_tscg(1,x))
+
+
+ end function cc
+
+ function test (ipart,vois)
+ implicit none
+ integer :: ipart,vois
+ logical :: test
+ real(kind=8) :: x
+
+ test=.false.
+ x=(posz(mod(ipart-1+vois+npart,npart)+1) - real( floor((posz(mod(ipart-1+vois+npart,npart)+1)-zd)/dz) ,kind=8)*dz-zd)/dz
+ if ( ((blocg(mod(ipart-1+vois+npart,npart)+1)==0).or.(blocg(mod(ipart-1+vois+npart,npart)+1)==2)).and.(x>0.5)) test=.true.
+
+ end function test
+
+
+
+ subroutine calcul_phi_tvd(phi_out,num)
+ implicit none
+ integer :: num
+ real(kind=8),dimension(0:1),intent(out):: phi_out
+ real(kind=8),dimension(-5:5) :: u
+ real(kind=8) :: rp,rm,diff1,diff2,diff3,diff0,rmm,y,r
+ integer :: ib,jb
+ real(kind=8),dimension(-5:5) :: xx_vois,x,tp1,tp2,tp3
+
+ !particules voisines
+ !-------------------
+ do ib=-2,2
+ u(ib)=donne(mod(i-1+ib+npart,npart)+1)
+ end do
+
+ do ib=-1,2
+ x(ib)=(posz(mod(i-1+ib+npart,npart)+1) - real( floor((posz(mod(i-1+ib+npart,npart)+1)-zd)/dz) ,kind=8)*dz-zd)/dz
+ end do
+
+
+ !cas bloc centre xx>0.5 (psi)
+ !-----------------------
+ if (num==1) then
+
+ do ib=0,1
+ x(ib)=x(ib)-1.
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp3(ib)=4.*(x(ib)-0.5)**2
+ end do
+
+ do ib=0,1
+ r=(u(ib+1)-u(ib))/(u(ib)-u(ib-1))
+
+ !anti diffusif
+ !phi_out(ib)=max(0.,min(tp3(ib),tp1(ib)*r))
+
+ !du type Minmod (attention non justifié pour y>=0.8)
+ phi_out(ib)=max(0.,min(1.,4.*r))
+
+ !bornes dépendent de la condition cfl
+ !phi_out(ib)=max(0.,min(1.,tp3(ib),tp1(ib)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+
+
+
+ else
+ !sinon (phi)
+ !-----------------------
+
+
+ do ib=-1,0
+ tp1(ib)=6.-8.*x(ib)*x(ib)
+ tp2(ib)=4.*(x(ib)+0.5)**2
+ end do
+
+
+ do ib=0,1
+ r=(u(ib-1)-u(ib-2))/(u(ib)-u(ib-1))
+ !phi_out(ib)=max(0.,min(tp2(ib-1),tp1(ib-1)*r))
+ phi_out(ib)=max(0.,min(1.,4.*r))
+ !phi_out(ib)=max(0.,min(1.,tp2(ib-1),tp1(ib-1)*r))
+
+ if(abs(u(ib)-u(ib-1))<0.0000001) phi_out(ib)=0.
+ end do
+
+ end if
+
+
+ end subroutine calcul_phi_tvd
+
+
+ end subroutine limit_l2_bloc_z
+
+
+
+
+
+
+end module remaillage_mod
+
+
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/resultats_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/resultats_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..00b0917ff59003633ac559f0ed2b79d24b30bd82
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/resultats_mod.f90
@@ -0,0 +1,90 @@
+module resultats_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+
+ subroutine res_vtk_q (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')""
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A15)') "SCALARS U FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ !ordre i,k,j pour plot vtk de la sphere "droit"
+ do i=1,nx
+ do k=1,nz
+ do j=1,ny
+ write(11,'(f20.9)') real(qg(i,j,k))
+ end do
+ end do
+ end do
+
+
+ close (11)
+
+ end subroutine res_vtk_q
+
+ subroutine res_vtk (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')""
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A15)') "SCALARS U FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(f20.9)') real(qg(i,j,k))
+ end do
+ end do
+ end do
+
+ write(11,'(A21)') ""
+ write(11,'(A21)') "VECTORS VITESSE FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j,k)),real(vyg(i,j,k)),real(vzg(i,j,k))
+ end do
+ end do
+ end do
+
+ close (11)
+
+ end subroutine res_vtk
+
+
+
+
+end module resultats_mod
+
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/tab_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/tab_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..02efd03f3043ee0f448843159bb12ec5e550c8be
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/tab_mod.f90
@@ -0,0 +1,14 @@
+module tab_mod
+
+ !grille
+ real(kind=8),dimension(:,:,:),pointer :: qg,vxg,vyg,vzg,vxg1,vyg1,vzg1,vxg2,vyg2,vzg2,vxg3,vyg3,vzg3,vxg4,vyg4,vzg4,exa
+ real(kind=8),dimension(:),pointer :: xtab,ytab,ztab
+ integer,dimension(:,:,:),pointer :: numpg
+ !particule
+ real(kind=8),dimension(:),pointer :: xp,yp,zp,qp,vx,vy,vz,xp0,xp1,xp2,xp3,yp0,yp1,yp2,yp3,zp0,zp1,zp2,zp3
+ real(kind=8),dimension(:),pointer :: vx0,vx1,vx2,vx3,vx4,vx5,vy0,vy1,vy2,vy3,vy4,vy5,vz0,vz1,vz2,vz3,vz4,vz5
+ integer,dimension(:),pointer :: blocg,blocd,Nbloc
+
+
+
+end module tab_mod
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/tps_Petros.txt b/CodesEnVrac/CodesAdrien/split_3d_rapide/tps_Petros.txt
new file mode 100644
index 0000000000000000000000000000000000000000..e4960323d6b6ebe4d11b28009a31a7a0f75aed15
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/tps_Petros.txt
@@ -0,0 +1,43 @@
+
+CUTOFF 0.025
+------------
+
+mp4_100_rk4_tenso_dtP_cutP_t1_karma.tps
+ 73.4125880000000
+ 13718 30072
+
+l2b_100_o2_sp_cfl4_cutP_t1_karma.tps
+ 83.8412390000000
+ 13718 28648
+
+
+
+CUTOFF 10-4
+-----------
+
+mp4_100_rk2_tenso_dtP_cutm4_t1_karma.tps
+ 22.1133810000000
+ 13718 109841
+
+mp4_100_rk4_tenso_dtP_cutm4_t1_karma.tps
+ 191.911994000000
+ 13718 109808
+
+l2b_100_o2_sp_cfl4_cutm4_t1_karma.tps
+ 86.5654090000000 86.5654090000000
+ 13718 0 89526
+
+l2_100_o2_sp_cfl4_cutm4_t1_karma.tps
+ 15.5729730000000 15.5729730000000
+ 13718 0 85024
+
+l2_100_rk2_tenso_cfl4_cutm4_t1_karma.tps
+ 11.9207440000000 11.9207440000000
+ 13718 0 87452
+
+
+
+
+
+cfl4 -> dt=0.02
+dtP=dt Petros=2/150=0.0133
diff --git a/CodesEnVrac/CodesAdrien/split_3d_rapide/utile_mod.f90 b/CodesEnVrac/CodesAdrien/split_3d_rapide/utile_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0ad2996d2871a2431e486dbc2180b9e323f42427
--- /dev/null
+++ b/CodesEnVrac/CodesAdrien/split_3d_rapide/utile_mod.f90
@@ -0,0 +1,800 @@
+module utile_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+ subroutine alloc_sub
+ allocate (qg(1:nx,1:ny,1:nz),vxg(1:nx_gro,1:ny_gro,1:nz_gro),vyg(1:nx_gro,1:ny_gro,1:nz_gro),vzg(1:nx_gro,1:ny_gro,1:nz_gro))
+ allocate (xp(1:npart),qp(1:npart),vx(1:npart),yp(1:npart),vy(1:npart),zp(1:npart),vz(1:npart))
+
+ allocate (xtab(1:nx),ytab(1:ny),ztab(1:nz))
+ !allocate (exa(1:nx,1:ny,1:nz))
+
+ allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+
+
+ !rk3
+ allocate (xp2(1:npart),yp2(1:npart),zp2(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vx3(1:npart),vx4(1:npart),vy1(1:npart),vz1(1:npart))
+ allocate (xp0(1:npart))
+ allocate (vy2(1:npart),vy3(1:npart),vy4(1:npart),vy5(1:npart))
+ allocate (zp0(1:npart))
+ allocate (vz2(1:npart),vz3(1:npart),vz4(1:npart))
+
+ !rk4
+ allocate (xp3(1:npart),yp3(1:npart),zp3(1:npart))
+
+ !pour la correction de consistance
+ allocate (numpg(1:nx,1:ny,1:nz))
+ allocate (blocg(0:npart),blocd(0:npart),Nbloc(0:npart))
+ end subroutine alloc_sub
+
+
+
+ subroutine make_grille
+ implicit none
+ integer :: i,j,k
+
+ do k=1,nz
+ ztab(k)=zd+(k-1)*dz
+ end do
+ do j=1,ny
+ ytab(j)=yb+(j-1)*dy
+ end do
+ do i=1,nx
+ xtab(i)=xg+(i-1)*dx
+ end do
+
+ end subroutine make_grille
+
+
+ function tsource(t,x,y,z)
+ implicit none
+ real(kind=8),intent(in) :: t,x,y,z
+ real(kind=8) :: tsource,t1,t2,t3,c1,c2,c3
+
+ t2=0.2
+ t3=0.3
+
+ !u=u(t,x,y,z)
+ !------------
+ c1=cos(2.*pi*x)*cos(2.*pi*y)*cos(2.*pi*z)
+ c2=cos(pi*t/t2)*cos(pi*t/t3)
+ c3=sin(2.*pi*x)*sin(2.*pi*y)*sin(2.*pi*z)
+
+ tsource=-pi*(sin(pi*t/t2)*c1)/t2 &
+ +2.*pi*c3*c2*c1&
+ -4.*pi*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z)*c2*sin(2.*pi*x)*cos(2.*pi*y)*cos(2.*pi*z)&
+ -pi*c3*c2*c1&
+ +2.*pi*sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)*c2*cos(2.*pi*x)*sin(2.*pi*y)*cos(2.*pi*z)&
+ -pi*c3*c2*c1&
+ +2.*pi*sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2*c2*cos(2.*pi*x)*cos(2.*pi*y)*sin(2.*pi*z)
+!!$
+!!$ tsource=0.
+
+ end function tsource
+
+
+subroutine source_rk4
+ use advection_mod
+ implicit none
+ integer :: i
+ real(kind=8) :: rk1,rk2,rk3,rk4,t1,t2,t3
+ real(kind=8) :: x1,x2,x3,y1,y2,y3,z1,z2,z3
+ real(kind=8) :: v1x,v2x,v3x,v1y,v2y,v3y,v1z,v2z,v3z
+
+
+
+ do i=1,npart
+
+ !euler
+ !------
+ !qp(i)=qp(i)+dt*tsource(time,xp(i),yp(i),zp(i))
+
+ !rk2
+ !----
+ !qp(i)=qp(i)+dt*tsource(time+0.5*dt,xp(i)+0.5*dt*vx(i),yp(i)+0.5*dt*vy(i),zp(i)+0.5*dt*vz(i))
+
+
+ !rk4
+ !---
+ rk1=tsource(time,xp(i),yp(i),zp(i))
+ x1=xp(i)+0.5*dt*vx(i)
+ y1=yp(i)+0.5*dt*vy(i)
+ z1=zp(i)+0.5*dt*vz(i)
+ rk2=tsource(time+0.5*dt,x1,y1,z1)
+ call evalv (v1x,v1y,v1z,time+0.5*dt,x1,y1,z1)
+ x2=xp(i)+0.5*dt*v1x
+ y2=yp(i)+0.5*dt*v1y
+ z2=zp(i)+0.5*dt*v1z
+ rk3=tsource(time+0.5*dt,x2,y2,z2)
+ call evalv (v2x,v2y,v2z,time+0.5*dt,x2,y2,z2)
+ x3=xp(i)+dt*v2x
+ y3=yp(i)+dt*v2y
+ z3=zp(i)+dt*v2z
+ rk4=tsource(time+dt,x3,y3,z3)
+
+ qp(i)=qp(i)+dt*(rk1+2.*rk2+2.*rk3+rk4)/6.
+
+ end do
+
+
+ end subroutine source_rk4
+
+
+ subroutine source_split_1
+ implicit none
+ integer :: i
+
+ !ordre2
+ !------
+ do i=1,npart
+ qp(i)=qp(i)+0.5*dt*tsource(time,xp(i),yp(i),zp(i))
+ end do
+
+
+ end subroutine source_split_1
+
+ subroutine source_split_2
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+
+ !ordre2
+ !------
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ qg(i,j,k)=qg(i,j,k)+0.5*dt*tsource(time+dt,x,y,z)
+ !qg(i,j,k)=qg(i,j,k)+0.5*dt*tsource(time,x,y,z)
+
+ end do
+ end do
+ end do
+
+ end subroutine source_split_2
+
+
+
+ subroutine make_bloc(esp)
+ use donnees_mod
+ implicit none
+ integer,intent(in) :: esp
+ integer :: fin,ib,i,j,k,l,im,ip,dim1,dim2,dim3
+ logical :: zero
+ real(kind=8) :: pas
+
+ select case(esp)
+ case(1)
+ dim1=nx
+ dim2=ny
+ dim3=nz
+ pas=dx
+ case(2)
+ dim1=ny
+ dim2=nz
+ dim3=nx
+ pas=dy
+ case(3)
+ dim1=nz
+ dim2=nx
+ dim3=ny
+ pas=dz
+ end select
+
+
+ !-----------------------------------------------------------------------------------------
+ !Determine la nature des blocs
+ !Donne un flag correspondant au type de remaillage necessaire (centre,decentre ou modifie)
+ !------------------------------------------------------------------------------------------
+
+ blocg(1:npart)=1
+ blocd(1:npart)=1
+
+ direction1: do l=1,dim3
+
+ direction2: do j=1,dim2
+
+ !peut calculer la longeur -> gain si longeur eleve
+
+ !parcours la grille, bloc par bloc:determine le type des bloc
+ !---------------------------------
+
+ blocg(0)=100
+ blocd(0)=100
+ Nbloc(0)=100
+
+ type_bloc:do i=1,dim1,long_bloc+1
+
+
+ if ( (i+long_bloc)<(dim1-1) ) then
+ fin=i+long_bloc
+ call sub_typeb
+ else
+ !parcours le bloc plus premier point du bloc suivant
+ fin=dim1-1
+ call sub_typeb
+ blocg(pg(dim1,j,l))=blocg(pg(dim1-1,j,l))
+ blocd(pg(dim1,j,l))=blocd(pg(dim1-1,j,l))
+ Nbloc(pg(dim1,j,l))=Nbloc(pg(dim1-1,j,l))
+ end if
+
+ end do type_bloc
+
+ !parcours la grille, bloc par bloc:determine si modif de remaillage necessaire a l'intersection des blocs
+ !---------------------------------
+ type_remaill:do i=1,dim1,long_bloc+1
+
+ if (((i+long_bloc)<dim1).and.(i>1+long_bloc)) then
+ fin=i+long_bloc
+ call sub_remb
+ else
+ if (i<=1+long_bloc)then
+ !premier bloc
+ !-------------
+ fin=i+long_bloc
+ call sub_remb
+
+ else
+ !dernier bloc
+ !-------------
+ fin=dim1
+ call sub_remb
+
+ end if
+
+ end if
+
+ end do type_remaill
+ end do direction2
+ end do direction1
+
+ contains
+
+ subroutine sub_typeb
+
+ integer :: ni,N
+ real(kind=8) :: li
+ logical :: pasfait
+
+
+ !parcours une premiere fois le bloc pour savoir si c'est un bloc en 0 ou 1/2
+ !----------------------------------
+ pasfait=.true.
+ zero=.true.
+ do_zero:do ib=i,fin+1 !eviter cas change de bloc quand maille vide
+ if (pg(ib,j,l)/=0) then
+ if (pasfait) then !le N doit etre le meme pour tout le bloc !
+ li=dt/pas*vit(pg(ib,j,l))
+ ni=floor(li+0.5)
+ pasfait=.false.
+ end if
+ li=dt/pas*vit(pg(ib,j,l))
+ if ( ((li)<(ni-0.5)).or.((li)>(ni+0.5)) ) then
+ zero=.false.
+ exit do_zero
+ end if
+ end if
+ end do do_zero
+
+
+ !parcours a nouveau le bloc
+ !-------------------------
+ !affecte le type de bloc a toute les part du bloc
+
+ pasfait=.true.
+ bloc2:do ib=i,fin
+
+ if (pg(ib,j,l)/=0) then
+
+ !calcul de N
+ !------------
+ if (pasfait) then
+ if (zero) then
+ N=floor(dt/pas*vit(pg(ib,j,l))+0.5)
+ pasfait=.false.
+ else
+ N=floor(dt/pas*vit(pg(ib,j,l)))
+ pasfait=.false.
+ end if
+ end if
+
+ if (zero) then
+ !bloc pour lambda2 centre
+ blocg(pg(ib,j,l))=0
+ blocd(pg(ib,j,l))=0
+ end if
+
+ !affecte la constante N
+ Nbloc(pg(ib,j,l))=N
+
+ end if
+ end do bloc2
+
+ end subroutine sub_typeb
+
+
+ subroutine sub_remb
+ implicit none
+
+ integer,dimension(-2:2) :: iper
+ integer :: k
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection de ces blocs
+
+ if (i==fin) then
+ blocg(i)=blocg(i-1)
+ blocd(i)=blocd(i-1)
+ else
+ bloc3:do ib=i,fin,fin-i
+
+ if (pg(ib,j,l)/=0) then
+
+ !si fin de bloc en 0. :
+ !----------------------
+ do k=-2,2
+ iper(k)=pg(mod(ib+k+dim1-1,dim1)+1,j,l)
+ end do
+
+
+ if ((ib==fin).and.(blocd(pg(ib,j,l))==0).and.((blocg(iper(1))==1).or.(blocg(iper(2))==1)).and.((Nbloc(iper(1))==Nbloc(pg(ib,j,l))-1) .or.(Nbloc(iper(2))==Nbloc(pg(ib,j,l))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j,l))<=Nbloc(pg(ib,j,l)) ) then
+ blocg(iper(1))=2
+ blocd(pg(ib,j,l))=3
+ else
+ blocg(iper(1))=2
+ blocd(pg(ib,j,l))=4
+ blocg(pg(ib,j,l))=5
+ end if
+
+ else
+ blocg(iper(1))=2
+ blocg(iper(2))=5
+
+ if ( dt/pas*vit(pg(ib,j,l))<=Nbloc(pg(ib,j,l)) ) then
+ blocd(pg(ib,j,l))=3
+ else
+ blocd(pg(ib,j,l))=7
+ blocg(pg(ib,j,l))=8
+ end if
+
+ if ( dt/pas*vit(iper(-1))<=Nbloc(pg(ib,j,l)) ) then
+ blocd(iper(-1))=6
+ else
+ blocd(iper(-1))=5
+ end if
+ end if
+
+ end if
+
+
+ !si debut de bloc en 0 : detecte quelle correction il faudra apporter
+ !----------------------
+ if ((ib==i) .and.(blocg(pg(ib,j,l))==0).and.((blocd(iper(-1))==1).or.(blocd(iper(-2))==1)).and.((Nbloc(iper(-1))==Nbloc(pg(ib,j,l))-1) .or. (Nbloc(iper(-2))==Nbloc(pg(ib,j,l))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j,l))>Nbloc(pg(ib,j,l)) ) then
+ blocd(iper(-1))=2
+ blocg(pg(ib,j,l))=4
+ else
+ blocd(iper(-1))=2
+ blocg(pg(ib,j,l))=3
+ end if
+
+ else
+
+ blocd(iper(-1))=2
+ blocd(iper(-2))=4
+
+ if ( dt/pas*vit(pg(ib,j,l))>Nbloc(pg(ib,j,l)) ) then
+ blocg(pg(ib,j,l))=4
+ else
+ blocg(pg(ib,j,l))=3
+ end if
+
+ if ( dt/pas*vit(iper(1))>Nbloc(pg(ib,j,l)) ) then
+ blocg(iper(1))=7
+ else
+ blocg(iper(1))=6
+ end if
+
+ end if
+ end if
+
+
+
+ end if
+ end do bloc3
+ end if
+
+ end subroutine sub_remb
+
+ function pg(a,b,c)
+ implicit none
+ integer,intent(in) :: a,b,c
+ integer :: pg
+
+ select case (esp)
+ case(1)
+ pg=numpg(a,b,c)
+ case(2)
+ pg=numpg(c,a,b)
+ case(3)
+ pg=numpg(b,c,a)
+ end select
+
+ end function pg
+
+ function vit(ind)
+ implicit none
+ integer,intent(in) :: ind
+ real(kind=8) :: vit
+
+ select case (esp)
+ case(1)
+ vit=vx(ind)
+ case(2)
+ vit=vy(ind)
+ case(3)
+ vit=vz(ind)
+ end select
+
+ end function vit
+
+
+ end subroutine make_bloc
+
+
+
+subroutine make_bloc_v2(esp)
+ use donnees_mod
+ implicit none
+ integer,intent(in) :: esp
+ integer :: fin,ib,i,j,k,l,im,ip,dim1,dim2,dim3
+ integer :: n,np,part,partp,partm,partpp
+ real(kind=8) :: pas
+
+ select case(esp)
+ case(1)
+ dim1=nx
+ dim2=ny
+ dim3=nz
+ pas=dx
+ case(2)
+ dim1=ny
+ dim2=nz
+ dim3=nx
+ pas=dy
+ case(3)
+ dim1=nz
+ dim2=nx
+ dim3=ny
+ pas=dz
+ end select
+
+ !-----------------------------------------------------------------------------------------
+ !Determine la nature des blocs
+ !Donne un flag correspondant au type de remaillage necessaire (centre,decentre ou modifie)
+ !------------------------------------------------------------------------------------------
+
+ blocg(1:npart)=1
+ blocd(1:npart)=1
+
+ blocg(0)=100
+ blocd(0)=100
+ Nbloc(0)=100
+
+
+
+ direction1: do l=1,dim3
+
+ direction2: do j=1,dim2
+
+ !peut calculer la longeur -> gain si longeur eleve
+
+ !parcours la grille, bloc par bloc:determine le type des bloc
+ !---------------------------------
+
+ type_bloc:do i=1,dim1,long_bloc+1
+
+
+ if ( (i+long_bloc)<(dim1-1) ) then
+ fin=i+long_bloc
+ call sub_typeb
+ else
+ !parcours le bloc plus premier point du bloc suivant
+ do k=i,dim1
+ blocg(pg(k,j,l))=blocg(pg(i-1,j,l))
+ blocd(pg(k,j,l))=blocd(pg(i-1,j,l))
+ Nbloc(pg(k,j,l))=Nbloc(pg(i-1,j,l))
+ end do
+ end if
+
+ end do type_bloc
+
+ !parcours la grille, bloc par bloc:determine si modif de remaillage necessaire a l'intersection des blocs
+ !---------------------------------
+ type_remaill:do i=1,dim1,long_bloc+1
+
+ if ((i+long_bloc)<dim1) then
+
+ fin=i+long_bloc
+
+ k=fin
+ do while ((pg(k,j,l)==0).and.(k>i))
+ k=k-1
+ end do
+ n=Nbloc(pg(k,j,l)) ! s'il n'y a pas de part dans le bloc N=100 -> ne fera pas de correction
+
+ k=fin+1
+ do while ((pg(k,j,l)==0).and.(k<(fin+long_bloc+2)).and.(k<nx))
+ k=k+1
+ end do
+ np=Nbloc(pg(k,j,l))
+
+ part=pg(fin,j,l)
+ partp=pg(fin+1,j,l)
+ partm=pg(fin-1,j,l)
+ partpp=pg(fin+2,j,l)
+
+ if (type_b==2) call sub_remb_2(n,np,part,partp)
+ if (type_b==4) call sub_remb_4(n,np,part,partp,partm,partpp)
+
+
+ else
+
+ !dernier bloc
+ !-------------
+ fin=dim1
+
+ k=fin
+ do while ((pg(k,j,l)==0).and.(k>i))
+ k=k-1
+ end do
+ n=Nbloc(pg(k,j,l))
+
+ k=1
+ do while ((pg(k,j,l)==0).and.(k<(1+long_bloc+1)))
+ k=k+1
+ end do
+ np=Nbloc(pg(k,j,l))
+
+ part=pg(fin,j,l)
+ partp=pg(1,j,l)
+ partm=pg(fin-1,j,l)
+ partpp=pg(2,j,l)
+
+ if (type_b==2) call sub_remb_2(n,np,part,partp)
+ if (type_b==4) call sub_remb_4(n,np,part,partp,partm,partpp)
+
+
+ end if
+
+ end do type_remaill
+ end do direction2
+ end do direction1
+
+ contains
+
+ subroutine sub_typeb
+
+ integer :: N,intl
+ real(kind=8) :: li,lmin
+
+
+ !parcours une premiere fois le bloc pour savoir si c'est un bloc en 0 ou 1/2
+ !----------------------------------
+ lmin=99999999999999999999999.
+ do_lmin:do ib=i,fin
+ if (pg(ib,j,l)/=0) then
+ li=dt/pas*vit(pg(ib,j,l))
+ lmin=min(lmin,li)
+ end if
+ end do do_lmin
+
+ !calcul du type de bloc et de N
+ !-------------------------------
+ intl=floor(lmin)
+ if ((lmin-intl).le.0.5) then
+ !type gauche
+ !-----------
+ N=intl
+ do_typeg:do ib=i,fin
+ if (pg(ib,j,l)/=0) then
+ blocg(pg(ib,j,l))=1
+ blocd(pg(ib,j,l))=1
+ Nbloc(pg(ib,j,l))=N
+ end if
+ end do do_typeg
+ else
+ !type centre
+ !-----------
+ N=intl+1
+ do_typec:do ib=i,fin
+ if (pg(ib,j,l)/=0) then
+ blocg(pg(ib,j,l))=0
+ blocd(pg(ib,j,l))=0
+ Nbloc(pg(ib,j,l))=N
+ end if
+ end do do_typec
+ end if
+
+ end subroutine sub_typeb
+
+ subroutine sub_remb_2(n,np,partf,partfp)
+ !attention les bords ne sont pas bien traités
+ implicit none
+
+ integer,intent(in) ::n,np,partf,partfp
+ real(kind=8) :: li
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection des blocs
+ if ((np) == (n-1)) then
+ li=dt/pas*vit(partf)
+ if ( (li<n).and.(blocg(partf)==0) ) then !seconde condition=bloc centre
+ blocg(partf)=2
+ else
+ blocg(partf)=3
+ end if
+ blocg(partfp)=4
+ end if
+ if ((np) == (n+1)) then
+ li=dt/pas*vit(partfp)
+ blocg(partf)=5
+ if ((li<np).and.(blocg(partfp)==0)) then
+ blocg(partfp)=6
+ else
+ blocg(partfp)=7
+ end if
+ end if
+
+
+
+ end subroutine sub_remb_2
+
+
+ subroutine sub_remb_4(n,np,partf,partfp,partfm,partfpp)
+ !attention les bords ne sont pas bien traités
+ implicit none
+
+ integer,intent(in) ::n,np,partf,partfp,partfm,partfpp
+ real(kind=8) :: li
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection des blocs
+
+ !N_{m+1}=N_m -1
+ !--------------
+ if ((np) == (n-1)) then
+ !si bloc centre
+ if (blocd(partfm)==0) then
+ li=dt/pas*vit(partfm)
+ if ( (li<n) ) then
+ blocd(partfm)=2
+ else
+ blocd(partfm)=3
+ end if
+ else
+ blocd(partfm)=3
+ end if
+ if (blocg(partf)==0) then
+ li=dt/pas*vit(partf)
+ if ( (li<n) ) then
+ blocg(partf)=2
+ blocd(partf)=4
+ else
+ blocg(partf)=3
+ blocd(partf)=5
+ end if
+ else
+ blocg(partf)=3
+ blocd(partf)=5
+ end if
+ blocg(partfp)=4
+ blocd(partfp)=1
+ li=dt/pas*vit(partfpp)
+ if ( (blocg(partfpp)==0).and.(li<np) ) then
+ blocg(partfpp)=5
+ else
+ blocg(partfpp)=6
+ end if
+ end if
+ !N_{m+1}=N_m +1
+ !--------------
+ if ((np) == (n+1)) then
+ li=dt/pas*vit(partfm)
+ if ( (blocd(partfm)==0).and.(li<n) ) then
+ blocd(partfm)=6
+ else
+ blocd(partfm)=7
+ end if
+ blocg(partf)=1
+ blocd(partf)=8
+ if (blocg(partfp)==0) then
+ li=dt/pas*vit(partfp)
+ if ( (li<np) ) then
+ blocg(partfp)=7
+ blocd(partfp)=0
+ else
+ blocg(partfp)=8
+ blocd(partfp)=1
+ end if
+ else
+ blocg(partfp)=8
+ blocd(partfp)=1
+ end if
+ if (blocg(partfpp)==0) then
+ li=dt/pas*vit(partfpp)
+ if ( (li<np) ) then
+ blocg(partfpp)=9
+ else
+ blocg(partfpp)=10
+ end if
+ else
+ blocg(partfpp)=10
+ end if
+
+ end if
+
+
+
+ end subroutine sub_remb_4
+
+
+ function pg(a,b,c)
+ implicit none
+ integer,intent(in) :: a,b,c
+ integer :: pg
+
+ select case (esp)
+ case(1)
+ pg=numpg(a,b,c)
+ case(2)
+ pg=numpg(c,a,b)
+ case(3)
+ pg=numpg(b,c,a)
+ end select
+
+ end function pg
+
+ function vit(ind)
+ implicit none
+ integer,intent(in) :: ind
+ real(kind=8) :: vit
+
+ select case (esp)
+ case(1)
+ vit=vx(ind)
+ case(2)
+ vit=vy(ind)
+ case(3)
+ vit=vz(ind)
+ end select
+
+ end function vit
+
+
+ end subroutine make_bloc_v2
+
+
+
+ end module utile_mod
+
+
diff --git a/CodesEnVrac/LEGI/src/cart_topology.f90 b/CodesEnVrac/LEGI/src/cart_topology.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6985a4fa72262261c506108ac80574e07b39e6f2
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/cart_topology.f90
@@ -0,0 +1,288 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: cart_topology
+!
+!
+! DESCRIPTION:
+!> This module provide a cartesien topology on the parrallel layout.
+!! This virtual topology is created by the MPI procedures (and thus use
+!! low-level optimisation based on the underlyinfg hardware). It
+!! provides the different tools to create, to manipulate and to interface
+!! it with the other topology and communicators.
+!! The solver use some dimensionnal splitting and this module contains all the
+!! method used to solve advection along the Y-axis. This is a parallel
+!! implementation using MPI and the cartesien topology it provides.
+!!
+!! Nowaday, the domain is only splitted along Y and Z axis. Therefore,
+!! we only use a 2D cartesian topology.
+!! A "global" communicator is devoted to the (2D) cartesian structure.
+!! Another communicator is added for each direction in order to deal
+!! with all 1D communication (along Y or Z).
+!! Be careful : the (Y,Z)-axis in the 3D mesh match to the (X,Y) axis on the 2D
+!! mpi-topology.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module cart_topology
+
+ use precision
+
+ implicit none
+
+ public
+
+ ! ===== Public variables =====
+
+ ! ----- Communicators -----
+ !> Communicator associated with the cartesian topology
+ integer :: cart_comm
+ !> Communicators devoted to 1-dimensionnal subgrids (along Y and Z)
+ integer :: X_comm, Y_comm, Z_comm
+ !> Table of the preivious communicators (ie comm devoted to 1D subgrids)
+ integer, dimension(3) :: D_comm
+
+ ! ----- Information about mesh subdivision and on the global grid -----
+ !> number of processes in each direction
+ integer, dimension(3) :: nb_proc_dim
+ !> information about min and max local indice on the current directory
+ integer, dimension(3) :: begin_proc, end_proc
+ !> space lengh of th domain
+ real(WP), dimension(3) :: length
+ !> space step for scalar discretisation
+ real(WP), dimension(3) :: d_sc
+ !> number of (sub)grid in each direction
+ integer, dimension(3) :: N!, N_proc
+ integer, dimension(3) :: N_proc
+ !> rank of current processus (in the cartesian communicator)
+ integer :: myrank
+ !> coordinate of the current processus
+ integer, dimension(3) :: coord
+ !> YZ coordinate of the current processus
+ integer, dimension(2) :: coordYZ
+ !> Periodic boundary conditions : logical array, equals true if periodic
+ logical, dimension(3) :: periods
+ !> Computation are done by group of line. Here we define their size
+ integer, dimension(3,2) :: group_size
+ !> To concatenate position in order to create unique mpi message tag
+ integer, dimension(3,2) :: tag_size
+ !> To concatenate rank in order to create unique mpi message tag
+ integer :: tag_rank
+
+
+ ! ==== Public procedures ====
+ !> Creation of the cartesian topology
+ public :: cart_create
+ !> Initialise mesh information
+ public :: mesh_default
+ public :: mesh_init
+ !> Compute tag for mpi message
+ public :: compute_tag_gap
+ public :: compute_tag_NP
+
+ interface compute_tag
+ module procedure compute_tag_gap, compute_tag_NP
+ end interface compute_tag
+
+contains
+
+!> Creation of the cartesian mesh and of all communicators
+subroutine cart_create(dims, ierr)
+
+ use mpi
+ use parallel
+
+ !> @param[in] dims = array specifying the number of processes in each dimension
+ !> @param[out] ierr = error code
+ integer, dimension(2), intent(in) :: dims
+ integer, intent(out) :: ierr
+
+ logical :: reorganisation ! to choose to reordered or not the processus rank.
+ logical, dimension(3) :: remains_dim ! use to create 1D-subdivision : remains_dims(i) equal
+ ! true if the i-th dimension is kept in the subgrid.
+ ! Creation of the cartesian topology
+ reorganisation = .true.
+ periods = .true.
+ nb_proc_dim = (/ 1, dims(1), dims(2) /)
+
+ call mpi_cart_create(MPI_COMM_WORLD, 3, nb_proc_dim, periods, reorganisation, &
+ & cart_comm, ierr)
+
+
+ ! Subdivision in 1D-subgrids and creation of communicator devoted to
+ ! 1D-communication
+ ! Communication along X-axis
+ remains_dim = (/.true., .false., .false. /)
+ call mpi_cart_sub(cart_comm, remains_dim, X_comm, ierr)
+ D_comm(1) = X_comm
+ ! Communication along Y-axis (in the 3D mesh, ie the x-axis on the mpi-topology)
+ remains_dim = (/.false., .true., .false. /)
+ call mpi_cart_sub(cart_comm, remains_dim, Y_comm, ierr)
+ D_comm(2) = Y_comm
+ ! Communication along Z-axis
+ remains_dim = (/ .false., .false., .true. /)
+ call mpi_cart_sub(cart_comm, remains_dim, Z_comm, ierr)
+ D_comm(3) = Z_comm
+
+ ! Initialise information about the current processus
+ call mpi_comm_rank(cart_comm, myrank, ierr)
+ call mpi_cart_coords(cart_comm, myrank, 3, coord, ierr)
+ coordYZ = (/ coord(2), coord(3) /)
+
+ ! XXX ajouter un test du code d'erreur mpi
+! if(ierr/=MPI_SUCCESS) then
+! call parallel_error(ierr, 'cart_create')
+! end if
+
+end subroutine cart_create
+
+!> Defaut mesh setup
+subroutine mesh_default()
+
+ ! A cubic geometry : unitary lengh and 100 mesh points in each direction.
+ N = 100
+ length = 1.
+ length = 1
+ N_proc = N / nb_proc_dim
+ begin_proc = 1
+ end_proc = N_proc
+
+ call mesh_init()
+
+end subroutine mesh_default
+
+!> To initialize last mesh parameters
+subroutine mesh_init()
+
+ integer :: direction ! direction (along X = 1, along Y = 2, along Z = 3)
+ integer :: group_dir ! direction "bis"
+ integer, dimension(3,2) :: N_group ! number of group on one processus along one direction
+
+ d_sc = length/(N)
+
+ ! XXX Pour le moment, on travaille par groupe d'une unique ligne
+ group_size = 1
+
+ ! Compute number of group
+ ! Group of line along X
+ N_group(1,1) = N_proc(2)/group_size(1,1)
+ N_group(1,2) = N_proc(3)/group_size(1,2)
+ ! Group of line along X
+ N_group(2,1) = N_proc(1)/group_size(2,1)
+ N_group(2,2) = N_proc(3)/group_size(2,2)
+ ! Group of line along X
+ N_group(3,1) = N_proc(1)/group_size(3,1)
+ N_group(3,2) = N_proc(2)/group_size(3,2)
+
+
+ ! tag_size = smallest power of ten to ensure tag_size > max ind_group
+ do direction = 1,3
+ tag_size(direction,:) = 1
+ do group_dir = 1,2
+ do while (N_group(direction, group_dir)/(10**tag_size(direction, group_dir))>1)
+ tag_size(direction, group_dir) = tag_size(direction, group_dir)+1
+ end do
+ end do
+ end do
+
+ tag_rank = 1
+ do while((nb_proc_dim(1)+nb_proc_dim(2)+nb_proc_dim(3))/(10**tag_rank)>=1)
+ tag_rank = tag_rank+1
+ end do
+ if (tag_rank == 1) tag_rank = 2
+
+
+if(myrank==0) then
+ print*, ' '
+ print*, ' -- initialisation: tag generation --'
+ do direction = 1,3
+ print*, 'tag_size(',direction,',:) = ', tag_size(direction,:)
+ end do
+ print*, 'tag_rank = ', tag_rank
+ print*, ' ------------------------------------'
+ print*, ' '
+end if
+
+end subroutine mesh_init
+
+!> Compute unique tag for mpi message by concatenation of position (ie line coordinate), proc_gap and unique Id
+!! @param[in] ind_group = indice of current group of line
+!! @param[in] tag_param = couple of int unique for each message (used to create the tag)
+!! @param[in] direction = current direction
+!! @param[in] proc_gap = number of processus between the sender and the receiver
+!! @return tag = unique tag: at each message send during an iteration have a different tag
+!!@details
+!! Use this procedure to compute tag in order to communicate with a distant processus or/and when
+!! you will send more then two message. It produce longer tag compute_tag_NP because rather tyo use 0/1 it
+!! put the gap between the sender and the receiver (ie the number of processus between them) in the tag.
+!! Using these two procedure allow to obtain more unique tag for communication.
+function compute_tag_gap(ind_group, tag_param, direction,proc_gap) result(tag)
+
+ integer :: tag
+ integer, dimension(2), intent(in) :: ind_group
+ integer, dimension(2), intent(in) :: tag_param
+ integer, intent(in) :: direction
+ integer, intent(in) :: proc_gap
+
+ integer :: abs_proc_gap ! absolute value of proc_gap
+
+ abs_proc_gap = max(abs(proc_gap),1)
+ tag = (tag_param(1)*10+direction)*(10**(tag_rank+1))
+ tag = tag + abs_proc_gap*10 + dim(proc_gap/abs_proc_gap,0)
+ tag = tag*(10**tag_size(direction,1))+(ind_group(1)-1)
+ tag = ((tag*(10**tag_size(direction,2)))+(ind_group(2)-1))
+ tag = (tag*10)+tag_param(2)
+
+if ((tag<0) .and. (myrank==0)) then
+print*, 'ind_group = ', ind_group, ' ; tag_param = ', tag_param
+print*, 'direction = ', direction, ' gap = ', proc_gap ,' and tag = ', tag
+end if
+
+end function compute_tag_gap
+
+
+!> Compute unique tag for mpi message by concatenation of position(ie line coordinate), +1 or -1 and unique Id
+!! @param[in] ind_group = indice of current group of line
+!! @param[in] tag_param = couple of int unique for each message (used to create the tag)
+!! @param[in] direction = current direction
+!! @return tag_table = unique couple tag: use tag_table(1) for mesage to previous proc. (or first
+!! message ) and tag_table(2) for the other message.
+!!@details
+!! Use this procedure to compute tag for communication with your neighbor or when only two message are send:
+!! it produce smaller tag then compute_tag_gap because the gap between sender and receiver are replaced by 1,
+!! for communicate with previous processus (or first of the two message), or 0, for communication with next
+!! processus (or the second message). It allow to reuse some unique Id.
+function compute_tag_NP(ind_group, tag_param, direction) result (tag_table)
+
+ integer, dimension(2) :: tag_table
+ integer, dimension(2), intent(in) :: ind_group
+ integer, dimension(2), intent(in) :: tag_param
+ integer, intent(in) :: direction
+
+ tag_table(2) = (tag_param(1)*10+direction)*10
+ tag_table(1) = tag_table(2)
+
+ tag_table(2) = tag_table(2) +1
+
+ tag_table(2) = (tag_table(2)*(10**tag_size(direction,1)))+(ind_group(1)-1)
+ tag_table(1) = (tag_table(1)*(10**tag_size(direction,1)))+(ind_group(1)-1)
+
+ tag_table(2) = ((tag_table(2)*(10**tag_size(direction,2)))+(ind_group(2)-1))
+ tag_table(1) = ((tag_table(1)*(10**tag_size(direction,2)))+(ind_group(2)-1))
+
+ tag_table(2) = (tag_table(2)*10)+tag_param(2)
+ tag_table(1) = (tag_table(1)*10)+tag_param(2)
+
+if ((minval(tag_table)<0) .and. (myrank==0)) then
+print*, 'ind_group = ', ind_group, ' ; tag_param = ', tag_param
+print*, 'direction = ', direction, ' and tag = ', tag_table
+end if
+
+end function compute_tag_NP
+
+
+end module cart_topology
+
+
diff --git a/CodesEnVrac/LEGI/src/particles/advec.f90 b/CodesEnVrac/LEGI/src/particles/advec.f90
new file mode 100644
index 0000000000000000000000000000000000000000..95c03ef061581ae409c5a4b3d3bb6b5d0a22bc52
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/particles/advec.f90
@@ -0,0 +1,141 @@
+module advec
+
+ use string
+ implicit none
+
+ ! ===== Variables =====
+ !> numerical method use to advect the scalar
+ character(len=str_short), private :: type_part_solv
+ !> dimensionnal splitting (eg classical, Strang or particle)
+ character(len=str_short), private :: dim_splitting
+
+
+ ! ===== Public procedures =====
+
+ ! Scheme used to advec the scalar (order 2 or 4 ?)
+ public :: type_part_solver
+
+ ! Advection methods
+ public :: advec_init ! initialize the scalar solver
+ public :: advec_step ! advec the scalar field during a time step.
+
+contains
+
+! ===== Public methods =====
+
+!> Return the name of the particle method used for the advection
+function type_part_solver()
+ character(len=str_short) :: type_part_solver
+
+ type_part_solver = type_part_solv
+end function
+
+!> Initialise the particle advection methods
+!! @param order = to choose the remeshing method (and thus the order)
+subroutine advec_init(order)
+
+ use cart_topology
+ use advec_common
+
+ character(len=*), optional, intent(in) :: order
+
+ ! Remplissage de la valeur par defaut en l'absence de choix explicite de la méthode numérique
+ if(present(order)) then
+ type_solv = order
+ else
+ type_solv = 'p_O2'
+ end if
+
+ ! Initialisation part adapted to each method
+ select case(type_solv)
+ case('p_O2')
+ bl_size = 2
+ bl_bound_size = 1
+ case('p_O4')
+ bl_size = 4
+ bl_bound_size = 2
+ case default
+ bl_size = 2
+ bl_bound_size = 1
+ end select
+
+ ! Check if the subdomain contain a number of mesh wich could be divided by bl_size
+ if ((modulo(N_proc(1),bl_size)/=0).OR.(modulo(N_proc(2),bl_size)/=0).OR.(modulo(N_proc(3),bl_size)/=0)) then
+ if (myrank ==0) print*, 'Number of mesh by processus must be a muliple of ', bl_size
+ stop
+ end if
+
+ ! Compute local number of block along each direction
+ bl_number = N_proc/bl_size
+
+ ! Choosing the dimensionnal splitting to use
+ ! XXX parser le fichier input
+ dim_splitting = 'strang'
+
+end subroutine advec_init
+
+
+!> advec_scheme
+subroutine advec_step(dt, Vx, Vy, Vz, scal, dim_split)
+
+ use cart_topology
+ use advec_common
+ use advecX
+ use advecY
+ !use advecZ
+
+ ! @param[in] dt = time step
+ ! @param[in] Vx = velocity along x (could be discretised on a bigger mesh then the scalar)
+ ! @param[in] Vy = velocity along y
+ ! @param[in] Vz = velocity along z
+ ! @param[in,out] scal = scalar field to advect
+ ! @param[in] dim_split = dimensionnal splitting (eg classical,
+ !! Strang splitting or particle splitting)
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vx, Vy, Vz
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout):: scal
+ character(len=str_short), optional, intent(in) :: dim_split
+
+ character(len=str_short) :: splitting ! to choose the splitting
+
+ ! Default dimensionnal splitting if the user do not choose it
+ if(present(dim_split)) then
+ splitting = dim_split
+ else
+ splitting = dim_splitting
+ end if
+
+ ! Scheme used for advection : particle method (order 2 or 4) or spectral one.
+ if (type_solv=='spectral') then
+ print*, 'Solveur non implémenté'
+ end if
+
+ select case(splitting)
+ case('classical')
+ !call advecX_calc(dt, Vx, scal, type_part_solv)
+ call advecY_calc(dt, Vy, scal, type_part_solv)
+ !call advecZ_calc(dt, Vz, scal, type_part_solv)
+ case('Strang')
+ !call advecX_calc(dt/2.0, Vx, scal, type_part_solv)
+ call advecY_calc(dt/2.0, Vy, scal, type_part_solv)
+ !call advecZ_calc(dt/2.0, Vz, scal, type_part_solv)
+ !call advecZ_calc(dt/2.0, Vz, scal, type_part_solv)
+ call advecY_calc(dt/2.0, Vy, scal, type_part_solv)
+ !call advecX_calc(dt/2.0, Vz, scal, type_part_solv)
+ case default
+ !call advecX_calc(dt/2.0, Vx, scal, type_part_solv)
+ call advecY_calc(dt/2.0, Vy, scal, type_part_solv)
+ !call advecZ_calc(dt/2.0, Vz, scal, type_part_solv)
+ !call advecZ_calc(dt/2.0, Vz, scal, type_part_solv)
+ call advecY_calc(dt/2.0, Vy, scal, type_part_solv)
+ !call advecX_calc(dt/2.0, Vx, scal, type_part_solv)
+ end select
+
+end subroutine advec_step
+
+
+!> ===== Private procedure =====
+
+
+end module advec
+
diff --git a/CodesEnVrac/LEGI/src/particles/advecX.f90 b/CodesEnVrac/LEGI/src/particles/advecX.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0fceffa1d7dee78a713692cc31b930ee0a3196dc
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/particles/advecX.f90
@@ -0,0 +1,379 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: advecX
+!
+!
+! DESCRIPTION:
+!> This module is a part of the advection solver based on particles method.
+!! The solver use some dimensionnal splitting and this module contains all the
+!! method used to solve advection along the X-axis. This is a parallel
+!! implementation using MPI and the cartesien topology it provides.
+!!
+!! This module can use the method and variables defined in the module
+!! "advec_common" which gather information and tools shared for advection along
+!! x, y and z-axis.
+!!
+!! The module "test_advec" can be used in order to validate the procedures
+!! embedded in this module.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+!> @addtogroup part
+!! @{
+module advecX
+
+ use precision
+
+ implicit none
+
+ ! ===== Public procedures =====
+ !> Generique procedure to advect the scalar with a particles solver
+ public :: advecX_calc
+ !----- (corrected) Remeshing method (these methods are set to public in validation purposes) -----
+ public :: Xremesh_O2 ! order 2
+ public :: Xremesh_O4 ! order 4
+
+ ! ===== Private porcedures =====
+ !> particles solver with remeshing method at order 2
+ private :: advecX_calc_O2
+ private :: advecX_init ! initialize particle position, velocity and weight
+
+ contains
+
+! ===== Public procedure =====
+
+!> Scalar advection (this procedure call the right solver, depending on the simulation setup)
+!! @param[in] dt = time step
+!! @param[in] Vx = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] SC = scalar field to advect
+!! @param[in] type_solver = scheme use for the advection (particle with order 2 or 4)
+subroutine advecX_calc(dt, Vx, SC, type_solver)
+
+ use string
+ use cart_topology
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vx
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: SC
+ character(len=*), intent(in) :: type_solver
+
+
+
+ ! Call the right solver depending on the space order we want to.
+ select case(type_solver)
+ case('p_O2')
+ call advecX_calc_O2(dt, Vx, SC)
+ case default
+ call advecX_calc_O2(dt, Vx, SC)
+ end select
+
+end subroutine advecX_calc
+
+! ----- Remeshing procedures -----
+
+
+! ===== Private procedure =====
+
+! ---- Order 2 solver, with correction for large time step ----
+
+!> remeshing with an order 2 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in] bl_tag = contains information about bloc (is it tagged ?)
+!! @param[in] j,k = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in,out] scal = scalar field to advect
+subroutine Xremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,j,k,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: j, k
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+integer :: direction=1 ! current direction
+
+ real(WP), dimension(N_proc(1)) :: p_sc ! scalar advected by the particles
+ ! Variable used to remesh particles in a buffer
+ integer :: i ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+
+
+ ! -- Initialise particle weigth
+ do i = 1, N_proc(direction)
+ p_sc(i) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-1
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-1
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+1
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+1
+ end if
+
+ ! XXX j_min and j_max could be optimized !! (use that sub-domains cut
+ ! particles block in two egals parts)
+ allocate(send_buffer(send_j_min:send_j_max))
+ send_buffer = 0.0;
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do i = 1, N_proc(direction), bl_size
+ bl_ind = i/bl_size + 1
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ case (10)
+ ! no tag, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_left(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ case (110)
+ ! no tag and only centered particle
+ call AC_remesh_center(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ case (100)
+ ! no tag, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_center(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ ! XXX add the tagged cases
+ case (101)
+ ! tagged, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_tag_CL(p_pos_adim(i), p_sc(i), p_pos_adim(i+1), p_sc(i+1), send_buffer)
+ case (11)
+ ! tagged, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_tag_LC(p_pos_adim(i), p_sc(i), p_pos_adim(i+1), p_sc(i+1), send_buffer)
+ case default
+ print*, 'error on remeshing particles : bl_info equals to ', &
+ & bl_info, ' and must be 0, 10, 110, 100, 101 or 11. Mesh point = (',i, ', ', j,', ',k,')'
+ print*, 'paramètres du blocs : ind = ', bl_ind, ' , type(ind) = ', bl_type(bl_ind), &
+ & ' , type(ind+1) = ', bl_type(bl_ind+1), ' tag = ', bl_tag(bl_ind)
+ stop
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, X_comm, ind_group , send_j_min, send_j_max, send_buffer, scal(:,j,k))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Xremesh_O2
+
+
+!> remeshing with an order 4 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_tag = contains information about block (is it tagged ?)
+!! @param[in] j,k = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in,out] scal = scalar field to advect
+subroutine Xremesh_O4(ind_group, p_pos_adim, bl_type, bl_tag,j,k,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: j, k
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+ ! Variable used to remesh particles ...
+ ! ... and to communicate between subdomains. A variable prefixed by "send_"(resp "rece")
+ ! design something I send (resp. I receive).
+ real(WP), dimension(N_proc(1)) :: p_sc ! scalar advected by the particles
+ integer :: i ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+ integer :: proc_gap ! gap between my Y-coordinate and the one of the processus
+ ! with wich I communicate.
+ integer :: proc_min, proc_max ! minimal and maximal gap between my Y-coordinate and the one of
+ ! sub-domains wherein the particle will be remeshed.
+ integer :: ierr ! mpi error code
+ integer :: comm_size ! number of element to send/receive
+ integer :: tag ! mpi message tag
+ integer :: direction = 1 ! current direction = along Z
+
+ ! -- Initialise particle weigth
+ do i = 1, N_proc(direction)
+ p_sc(i) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-2
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-2
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+2
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+2
+ end if
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do i = 1, N_proc(direction), bl_size
+ bl_ind = i/2
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+2),p_sc(i+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+3),p_sc(i+3), send_buffer)
+ case (10)
+ ! no tag, the 2 first particles belong to a left block and the two last to centered block.
+ call AC_remesh_left(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+2),p_sc(i+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+3),p_sc(i+3), send_buffer)
+ case (110)
+ ! no tag and only left particle
+ call AC_remesh_center(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+2),p_sc(i+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+3),p_sc(i+3), send_buffer)
+ case (100)
+ ! no tag, the 2 first particles belong to a centered block and the two last to left block.
+ call AC_remesh_center(p_pos_adim(i),p_sc(i), send_buffer)
+ call AC_remesh_center(p_pos_adim(i+1),p_sc(i+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+2),p_sc(i+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(i+3),p_sc(i+3), send_buffer)
+ ! XXX add the tagged cases
+ case default
+ print*, 'error on remeshing particles'
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, X_comm, ind_group, send_j_min, send_j_max, send_buffer, scal(:,j,k))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Xremesh_O4
+
+
+!> Advection during a time step dt - order 2
+!! @param[in] dt = time step
+!! @param[in] Vx = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] scal3D = scalar field to advect
+subroutine advecX_calc_O2(dt,Vx,scal3D)
+
+ use cart_topology
+ use advec_common
+use mpi
+
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vx
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal3D
+
+ integer :: j,k ! indice of the currend mesh point
+ integer, dimension(2) :: ind_group ! indice of the currend group of line (=(i,k) by default)
+ integer :: direction=1 ! current direction = along Y
+ real(WP), dimension(N_proc(1)) :: p_pos_adim ! adimensionned particles position
+ real(WP), dimension(N_proc(1)) :: p_V ! particles velocity
+ integer, dimension(bl_number(1)+1) :: bl_type ! is the particle block a center block or a left one ?
+ integer, dimension(bl_number(1)) :: bl_tag ! indice of tagged particles
+integer :: ierr
+
+ ind_group = 0
+ do k = 1, N_proc(3)
+ ind_group(2) = ind_group(2) + 1
+ ind_group(1) = 0
+ do j = 1, N_proc(2)
+ ind_group(1) = ind_group(1) + 1
+
+ ! ===== Init particles =====
+ call advecX_init(Vx, j, k, p_pos_adim, p_V)
+
+ ! ===== Advection =====
+ ! -- Compute velocity (with a RK2 scheme) --
+ call AC_particle_velocity(dt, direction, X_comm, ind_group, p_pos_adim, p_V)
+ ! -- Determine blocks type and tag particles --
+ call AC_type_and_block(dt, direction, X_comm, ind_group, p_V, &
+ & bl_type, bl_tag)
+ ! -- Advec particles --
+ p_pos_adim = p_pos_adim + dt*p_V/d_sc(direction)
+
+ ! ===== Remeshing =====
+ call Xremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,j,k,scal3D)
+
+call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+ end do
+
+end subroutine advecX_calc_O2
+
+!> Particle creation and initialisation
+!! @param[in] Vx = 3D velocity field
+!! @param[in] j = Y-indice of the current line
+!! @param[in] k = Z-indice of the current line
+!! @param[out] p_pos_adim = adimensioned particles postion
+!! @param[out] p_V = particle velocity
+subroutine advecX_init(Vx, j, k, p_pos_adim, p_V)
+
+ use cart_topology
+
+ integer, intent(in) :: j,k
+ real(WP), dimension(N_proc(2)), intent(out) :: p_pos_adim, p_V
+ real(WP), dimension(:,:,:), intent(in) :: Vx
+
+ integer :: direction=1 ! current direction
+ integer :: ind ! indice
+
+ do ind = 1, N_proc(direction)
+ p_pos_adim(ind) = ind
+ p_V(ind) = Vx(ind,j,k)
+ end do
+
+end subroutine advecX_init
+
+end module advecX
+!! @}
diff --git a/CodesEnVrac/LEGI/src/particles/advecY.f90 b/CodesEnVrac/LEGI/src/particles/advecY.f90
new file mode 100644
index 0000000000000000000000000000000000000000..80f1413691d1ead3e85231a6b7a3c308d3b10dab
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/particles/advecY.f90
@@ -0,0 +1,379 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: advecY
+!
+!
+! DESCRIPTION:
+!> This module is a part of the advection solver based on particles method.
+!! The solver use some dimensionnal splitting and this module contains all the
+!! method used to solve advection along the Y-axis. This is a parallel
+!! implementation using MPI and the cartesien topology it provides.
+!!
+!! This module can use the method and variables defined in the module
+!! "advec_common" which gather information and tools shared for advection along
+!! x, y and z-axis.
+!!
+!! The module "test_advec" can be used in order to validate the procedures
+!! embedded in this module.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+!> @addtogroup part
+!! @{
+module advecY
+
+ use precision
+
+ implicit none
+
+ ! ===== Public procedures =====
+ !> Generique procedure to advect the scalar with a particles solver
+ public :: advecY_calc
+ !----- (corrected) Remeshing method (these methods are set to public in validation purposes) -----
+ public :: Yremesh_O2 ! order 2
+ public :: Yremesh_O4 ! order 4
+
+ ! ===== Private porcedures =====
+ !> particles solver with remeshing method at order 2
+ private :: advecY_calc_O2
+ private :: advecY_init ! initialize particle position, velocity and weight
+
+ contains
+
+! ===== Public procedure =====
+
+!> Scalar advection (this procedure call the right solver, depending on the simulation setup)
+!! @param[in] dt = time step
+!! @param[in] Vy = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] SC = scalar field to advect
+!! @param[in] type_solver = scheme use for the advection (particle with order 2 or 4)
+subroutine advecY_calc(dt, Vy, SC, type_solver)
+
+ use string
+ use cart_topology
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vy
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: SC
+ character(len=*), intent(in) :: type_solver
+
+
+
+ ! Call the right solver depending on the space order we want to.
+ select case(type_solver)
+ case('p_O2')
+ call advecY_calc_O2(dt, Vy, SC)
+ case default
+ call advecY_calc_O2(dt, Vy, SC)
+ end select
+
+end subroutine advecY_calc
+
+! ----- Remeshing procedures -----
+
+
+! ===== Private procedure =====
+
+! ---- Order 2 solver, with correction for large time step ----
+
+!> remeshing with an order 2 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in] bl_tag = contains information about bloc (is it tagged ?)
+!! @param[in] i,k = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in,out] scal = scalar field to advect
+subroutine Yremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,i,k,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: i, k
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+integer :: direction =2 ! current direction
+
+ real(WP), dimension(N_proc(2)) :: p_sc ! scalar advected by the particles
+ ! Variable used to remesh particles in a buffer
+ integer :: j ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+
+
+ ! -- Initialise particle weigth
+ do j = 1, N_proc(direction)
+ p_sc(j) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-1
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-1
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+1
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+1
+ end if
+
+ ! XXX j_min and j_max could be optimized !! (use that sub-domains cut
+ ! particles block in two egals parts)
+ allocate(send_buffer(send_j_min:send_j_max))
+ send_buffer = 0.0;
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do j = 1, N_proc(direction), bl_size
+ bl_ind = j/bl_size + 1
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ case (10)
+ ! no tag, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_left(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ case (110)
+ ! no tag and only centered particle
+ call AC_remesh_center(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ case (100)
+ ! no tag, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_center(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ ! XXX add the tagged cases
+ case (101)
+ ! tagged, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_tag_CL(p_pos_adim(j), p_sc(j), p_pos_adim(j+1), p_sc(j+1), send_buffer)
+ case (11)
+ ! tagged, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_tag_LC(p_pos_adim(j), p_sc(j), p_pos_adim(j+1), p_sc(j+1), send_buffer)
+ case default
+ print*, 'error on remeshing particles : bl_info equals to ', &
+ & bl_info, ' and must be 0, 10, 110, 100, 101 or 11. Mesh point = (',i, ', ', j,', ',k,')'
+ print*, 'paramètres du blocs : ind = ', bl_ind, ' , type(ind) = ', bl_type(bl_ind), &
+ & ' , type(ind+1) = ', bl_type(bl_ind+1), ' tag = ', bl_tag(bl_ind)
+ stop
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, Y_comm, ind_group , send_j_min, send_j_max, send_buffer, scal(i,:,k))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Yremesh_O2
+
+
+!> remeshing with an order 4 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_tag = contains information about block (is it tagged ?)
+!! @param[in] i,k = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in,out] scal = scalar field to advect
+subroutine Yremesh_O4(ind_group, p_pos_adim, bl_type, bl_tag,i,k,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: i, k
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+ ! Variable used to remesh particles ...
+ ! ... and to communicate between subdomains. A variable prefixed by "send_"(resp "rece")
+ ! design something I send (resp. I receive).
+ real(WP), dimension(N_proc(2)) :: p_sc ! scalar advected by the particles
+ integer :: j ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+ integer :: proc_gap ! gap between my Y-coordinate and the one of the processus
+ ! with wich I communicate.
+ integer :: proc_min, proc_max ! minimal and maximal gap between my Y-coordinate and the one of
+ ! sub-domains wherein the particle will be remeshed.
+ integer :: ierr ! mpi error code
+ integer :: comm_size ! number of element to send/receive
+ integer :: tag ! mpi message tag
+ integer :: direction = 2 ! current direction = along Z
+
+ ! -- Initialise particle weigth
+ do j = 1, N_proc(direction)
+ p_sc(j) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-2
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-2
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+2
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+2
+ end if
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do j = 1, N_proc(direction), bl_size
+ bl_ind = j/2
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+2),p_sc(j+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+3),p_sc(j+3), send_buffer)
+ case (10)
+ ! no tag, the 2 first particles belong to a left block and the two last to centered block.
+ call AC_remesh_left(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+2),p_sc(j+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+3),p_sc(j+3), send_buffer)
+ case (110)
+ ! no tag and only left particle
+ call AC_remesh_center(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+2),p_sc(j+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+3),p_sc(j+3), send_buffer)
+ case (100)
+ ! no tag, the 2 first particles belong to a centered block and the two last to left block.
+ call AC_remesh_center(p_pos_adim(j),p_sc(j), send_buffer)
+ call AC_remesh_center(p_pos_adim(j+1),p_sc(j+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+2),p_sc(j+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(j+3),p_sc(j+3), send_buffer)
+ ! XXX add the tagged cases
+ case default
+ print*, 'error on remeshing particles'
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, Y_comm, ind_group, send_j_min, send_j_max, send_buffer, scal(i,:,k))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Yremesh_O4
+
+
+!> Advection during a time step dt - order 2
+!! @param[in] dt = time step
+!! @param[in] Vy = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] scal3D = scalar field to advect
+subroutine advecY_calc_O2(dt,Vy,scal3D)
+
+ use cart_topology
+ use advec_common
+use mpi
+
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vy
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal3D
+
+ integer :: i,k ! indice of the currend mesh point
+ integer, dimension(2) :: ind_group ! indice of the currend group of line (=(i,k) by default)
+ integer :: direction=2 ! current direction = along Y
+ real(WP), dimension(N_proc(2)) :: p_pos_adim ! adimensionned particles position
+ real(WP), dimension(N_proc(2)) :: p_V ! particles velocity
+ integer, dimension(bl_number(2)+1) :: bl_type ! is the particle block a center block or a left one ?
+ integer, dimension(bl_number(2)) :: bl_tag ! indice of tagged particles
+integer :: ierr
+
+ ind_group = 0
+ do k = 1, N_proc(3)
+ ind_group(2) = ind_group(2) + 1
+ ind_group(1) = 0
+ do i = 1, N_proc(1)
+ ind_group(1) = ind_group(1) + 1
+
+ ! ===== Init particles =====
+ call advecY_init(Vy, i, k, p_pos_adim, p_V)
+
+ ! ===== Advection =====
+ ! -- Compute velocity (with a RK2 scheme) --
+ call AC_particle_velocity(dt, direction, Y_comm, ind_group, p_pos_adim, p_V)
+ ! -- Determine blocks type and tag particles --
+ call AC_type_and_block(dt, direction, Y_comm, ind_group, p_V, &
+ & bl_type, bl_tag)
+ ! -- Advec particles --
+ p_pos_adim = p_pos_adim + dt*p_V/d_sc(direction)
+
+ ! ===== Remeshing =====
+ call Yremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,i,k,scal3D)
+
+call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+ end do
+
+end subroutine advecY_calc_O2
+
+!> Particle creation and initialisation
+!! @param[in] Vy = 3D velocity field
+!! @param[in] i = X-indice of the current line
+!! @param[in] k = Z-indice of the current line
+!! @param[out] p_pos_adim = adimensioned particles postion
+!! @param[out] p_V = particle velocity
+subroutine advecY_init(Vy, i, k, p_pos_adim, p_V)
+
+ use cart_topology
+
+ integer, intent(in) :: i,k
+ real(WP), dimension(N_proc(2)), intent(out) :: p_pos_adim, p_V
+ real(WP), dimension(:,:,:), intent(in) :: Vy
+
+ integer :: direction=2 ! current direction
+ integer :: ind ! indice
+
+ do ind = 1, N_proc(direction)
+ p_pos_adim(ind) = ind
+ p_V(ind) = Vy(i,ind,k)
+ end do
+
+end subroutine advecY_init
+
+end module advecY
+!! @}
diff --git a/CodesEnVrac/LEGI/src/particles/advecZ.f90 b/CodesEnVrac/LEGI/src/particles/advecZ.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aa655077b0bef2c373a72c5f13ac83a27c2bfd50
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/particles/advecZ.f90
@@ -0,0 +1,386 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: advecZ
+!
+!
+! DESCRIPTION:
+!> This module is a part of the advection solver based on particles method.
+!! The solver use some dimensionnal splitting and this module contains all the
+!! method used to solve advection along the Z-axis. This is a parallel
+!! implementation using MPI and the cartesien topology it provides.
+!!
+!! This module can use the method and variables defined in the module
+!! "advec_common" which gather information and tools shared for advection along
+!! x, y and z-axis.
+!!
+!! The module "test_advec" can be used in order to validate the procedures
+!! embedded in this module.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+!> @addtogroup part
+!! @{
+module advecZ
+
+ use precision
+
+ implicit none
+
+ ! ===== Private variables =====
+ ! Minimal and maximal indice of the buffer used in the different communication
+ !> minimal indice of the send buffer
+ !integer, public :: send_j_min
+ !> maximal indice of the send buffer
+ !integer, public :: send_j_max
+
+ ! ===== Public procedures =====
+ !> Generique procedure to advect the scalar with a particles solver
+ public :: advecZ_calc
+ !----- (corrected) Remeshing method (these methods are set to public in validation purposes) -----
+ public :: Zremesh_O2 ! order 2
+ public :: Zremesh_O4 ! order 4
+
+ ! ===== Private porcedures =====
+ !> particles solver with remeshing method at order 2
+ private :: advecZ_calc_O2
+ private :: advecZ_init ! initialize particle position, velocity and weight
+
+ contains
+
+! ===== Public procedure =====
+
+!> Scalar advection (this procedure call the right solver, depending on the simulation setup)
+!! @param[in] dt = time step
+!! @param[in] Vz = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] SC = scalar field to advect
+!! @param[in] type_solver = scheme use for the advection (particle with order 2 or 4)
+subroutine advecZ_calc(dt, Vz, SC, type_solver)
+
+ use string
+ use cart_topology
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vz
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: SC
+ character(len=*), intent(in) :: type_solver
+
+
+
+ ! Call the right solver depending on the space order we want to.
+ select case(type_solver)
+ case('p_O2')
+ call advecZ_calc_O2(dt, Vz, SC)
+ case default
+ call advecZ_calc_O2(dt, Vz, SC)
+ end select
+
+end subroutine advecZ_calc
+
+! ----- Remeshing procedures -----
+
+
+! ===== Private procedure =====
+
+! ---- Order 2 solver, with correction for large time step ----
+
+!> remeshing with an order 2 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in] bl_tag = contains information about bloc (is it tagged ?)
+!! @param[in] i,j = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in,out] scal = scalar field to advect
+subroutine Zremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,i,j,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: i, j
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+integer :: direction =3 ! current direction
+
+ real(WP), dimension(N_proc(3)) :: p_sc ! scalar advected by the particles
+ ! Variable used to remesh particles in a buffer
+ integer :: k ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+
+
+ ! -- Initialise particle weigth
+ do k = 1, N_proc(direction)
+ p_sc(k) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-1
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-1
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+1
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+1
+ end if
+
+ ! XXX j_min and j_max could be optimized !! (use that sub-domains cut
+ ! particles block in two egals parts)
+ allocate(send_buffer(send_j_min:send_j_max))
+ send_buffer = 0.0;
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do k = 1, N_proc(direction), bl_size
+ bl_ind = k/bl_size + 1
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ case (10)
+ ! no tag, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_left(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ case (110)
+ ! no tag and only centered particle
+ call AC_remesh_center(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ case (100)
+ ! no tag, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_center(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ ! XXX add the tagged cases
+ case (101)
+ ! tagged, the first particle belong to a centered block and the last to left block.
+ call AC_remesh_tag_CL(p_pos_adim(k), p_sc(k), p_pos_adim(k+1), p_sc(k+1), send_buffer)
+ case (11)
+ ! tagged, the first particle belong to a left block and the last to centered block.
+ call AC_remesh_tag_LC(p_pos_adim(k), p_sc(k), p_pos_adim(k+1), p_sc(k+1), send_buffer)
+ case default
+ print*, 'error on remeshing particles : bl_info equals to ', &
+ & bl_info, ' and must be 0, 10, 110, 100, 101 or 11. Mesh point = (',i, ', ', j,', ',k,')'
+ print*, 'paramètres du blocs : ind = ', bl_ind, ' , type(ind) = ', bl_type(bl_ind), &
+ & ' , type(ind+1) = ', bl_type(bl_ind+1), ' tag = ', bl_tag(bl_ind)
+ stop
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, Z_comm, ind_group , send_j_min, send_j_max, send_buffer, scal(i,j,:))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Zremesh_O2
+
+
+!> remeshing with an order 4 method, corrected to allow large CFL number - untagged particles
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particles position
+!! @param[in] bl_tag = contains information about block (is it tagged ?)
+!! @param[in] i,j = indice of of the current line (x-coordinate and z-coordinate)
+!! @param[in] bl_type = equal 0 (resp 1) if the block is left (resp centered)
+!! @param[in,out] scal = scalar field to advect
+subroutine Zremesh_O4(ind_group, p_pos_adim, bl_type, bl_tag,i,j,scal)
+
+ use advec_common
+ use cart_topology
+
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: i, j
+ integer, dimension(:), intent(in) :: bl_type
+ integer, dimension(:), intent(in) :: bl_tag
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal
+
+ ! Variable used to remesh particles ...
+ ! ... and to communicate between subdomains. A variable prefixed by "send_"(resp "rece")
+ ! design something I send (resp. I receive).
+ real(WP), dimension(N_proc(3)) :: p_sc ! scalar advected by the particles
+ integer :: k ! indice of the current particle
+ integer :: bl_ind ! indice of the current "block end".
+ integer :: bl_info ! to know if particles are tagged and left/centered
+ ! (they depend on the block type)
+ real(WP),dimension(:),allocatable :: send_buffer ! buffer use to remesh the scalar before to send it to the right subdomain
+ integer :: proc_gap ! gap between my Y-coordinate and the one of the processus
+ ! with wich I communicate.
+ integer :: proc_min, proc_max ! minimal and maximal gap between my Y-coordinate and the one of
+ ! sub-domains wherein the particle will be remeshed.
+ integer :: ierr ! mpi error code
+ integer :: comm_size ! number of element to send/receive
+ integer :: tag ! mpi message tag
+ integer :: direction = 3 ! current direction = along Z
+
+ ! -- Initialise particle weigth
+ do k = 1, N_proc(direction)
+ p_sc(k) = scal(i,j,k)
+ scal(i,j,k) = 0
+ end do
+
+ ! -- Allocate and initialize the buffer --
+ if (bl_type(1)==0) then
+ ! First particle is a left one
+ send_j_min = floor(p_pos_adim(1))-2
+ else
+ ! First particle is a centered one
+ send_j_min = nint(p_pos_adim(1))-2
+ end if
+ if (bl_type(N_proc(direction)/bl_size +1)==0) then
+ ! Last particle is a left one
+ send_j_max = floor(p_pos_adim(N_proc(2)))+2
+ else
+ ! Last particle is a centered one
+ send_j_max = nint(p_pos_adim(N_proc(2)))+2
+ end if
+
+ ! -- Remesh the particles in the buffer --
+ ! The remeshing formula depends on the particle type :
+ ! 1 - Is the particle tagged ?
+ ! 2 - Does it belong to a centered or a left block ?
+ ! Observe that tagged particles go by group of two : if the particles of a
+ ! block end are tagged, the one first one of the following block are
+ ! tagged too.
+ ! The following algorithm is write for block of minimal size.
+ do k = 1, N_proc(direction), bl_size
+ bl_ind = k/2
+ bl_info = 100*bl_type(bl_ind)+(10*bl_type(bl_ind+1))+bl_tag(bl_ind)
+ select case (bl_info)
+ case (0)
+ ! no tag and only left particle
+ call AC_remesh_left(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+2),p_sc(k+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+3),p_sc(k+3), send_buffer)
+ case (10)
+ ! no tag, the 2 first particles belong to a left block and the two last to centered block.
+ call AC_remesh_left(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+2),p_sc(k+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+3),p_sc(k+3), send_buffer)
+ case (110)
+ ! no tag and only left particle
+ call AC_remesh_center(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+2),p_sc(k+2), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+3),p_sc(k+3), send_buffer)
+ case (100)
+ ! no tag, the 2 first particles belong to a centered block and the two last to left block.
+ call AC_remesh_center(p_pos_adim(k),p_sc(k), send_buffer)
+ call AC_remesh_center(p_pos_adim(k+1),p_sc(k+1), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+2),p_sc(k+2), send_buffer)
+ call AC_remesh_left(p_pos_adim(k+3),p_sc(k+3), send_buffer)
+ ! XXX add the tagged cases
+ case default
+ print*, 'error on remeshing particles'
+ end select
+ end do
+
+ ! -- Send the buffer to the matching processus and update the scalar field --
+ call AC_bufferToScalar(direction, Z_comm, ind_group, send_j_min, send_j_max, send_buffer, scal(i,j,:))
+
+ ! Deallocate all field
+ deallocate(send_buffer)
+
+end subroutine Zremesh_O4
+
+
+!> Advection during a time step dt - order 2
+!! @param[in] dt = time step
+!! @param[in] Vz = velocity along y (could be discretised on a bigger mesh then the scalar)
+!! @param[in,out] scal3D = scalar field to advect
+subroutine advecZ_calc_O2(dt,Vz,scal3D)
+
+ use cart_topology
+ use advec_common
+use mpi
+
+
+ real(WP), intent(in) :: dt
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(in) :: Vz
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(inout) :: scal3D
+
+ integer :: i,j ! indice of the currend mesh point
+ integer, dimension(2) :: ind_group ! indice of the currend group of line (=(i,k) by default)
+ integer :: direction=3 ! current direction = along Y
+ real(WP), dimension(N_proc(3)) :: p_pos_adim ! adimensionned particles position
+ real(WP), dimension(N_proc(3)) :: p_V ! particles velocity
+ integer, dimension(bl_number(3)+1) :: bl_type ! is the particle block a center block or a left one ?
+ integer, dimension(bl_number(3)) :: bl_tag ! indice of tagged particles
+integer :: ierr
+
+ ind_group = 0
+ do j = 1, N_proc(2)
+ ind_group(2) = ind_group(2) + 1
+ ind_group(1) = 0
+ do i = 1, N_proc(1)
+ ind_group(1) = ind_group(1) + 1
+
+ ! ===== Init particles =====
+ call advecZ_init(Vz, i, j, p_pos_adim, p_V)
+
+ ! ===== Advection =====
+ ! -- Compute velocity (with a RK2 scheme) --
+ call AC_particle_velocity(dt, direction, Z_comm, ind_group, p_pos_adim, p_V)
+ ! -- Determine blocks type and tag particles --
+ call AC_type_and_block(dt, direction, Z_comm, ind_group, p_V, &
+ & bl_type, bl_tag)
+ ! -- Advec particles --
+ p_pos_adim = p_pos_adim + dt*p_V/d_sc(direction)
+
+ ! ===== Remeshing =====
+ call Zremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag,i,j,scal3D)
+
+call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+ end do
+
+end subroutine advecZ_calc_O2
+
+!> Particle creation and initialisation
+!! @param[in] Vz = 3D velocity field
+!! @param[in] i = X-indice of the current line
+!! @param[in] j = Y-indice of the current line
+!! @param[out] p_pos_adim = adimensioned particles postion
+!! @param[out] p_V = particle velocity
+subroutine advecZ_init(Vz, i, j, p_pos_adim, p_V)
+
+ use cart_topology
+
+ integer, intent(in) :: i,j
+ real(WP), dimension(N_proc(3)), intent(out) :: p_pos_adim, p_V
+ real(WP), dimension(:,:,:), intent(in) :: Vz
+
+ integer :: direction=3 ! current direction
+ integer :: ind ! indice
+
+ do ind = 1, N_proc(direction)
+ p_pos_adim(ind) = ind
+ p_V(ind) = Vz(i,j,ind)
+ end do
+
+end subroutine advecZ_init
+
+end module advecZ
+!! @}
diff --git a/CodesEnVrac/LEGI/src/particles/advec_common.f90 b/CodesEnVrac/LEGI/src/particles/advec_common.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1b58e4e5dcc38810aae3a298695a76139ccc9265
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/particles/advec_common.f90
@@ -0,0 +1,1043 @@
+
+!> @addtogroup part
+!! @{
+module advec_common
+
+ use precision
+ use string
+
+ implicit none
+
+! XXX Si passage au fortran 2003 : basculer toutes ces variables dans le module
+! advec (fichier advec.F90) et mettre toutes les variables en protected.
+! Seul la procédure "advec_init" doit pouvoir les modifier, mais de nombreuses
+! procédures doivent pouvoir y accéder.
+
+
+ ! Information about the particles and their bloc
+ private
+ ! XXX Public variables have to be switched to "PROTECTED" when we will use fortran2003 norm
+
+ ! ===== Private variables =====
+ ! ----- Minimal and maximal indice of the buffer used in the different communication -----
+ !> minimal indice of the send buffer
+ integer, public :: send_j_min
+ !> maximal indice of the send buffer
+ integer, public :: send_j_max
+ ! ------ Block infromation -----
+ !> number of particles in a block
+ integer, public :: bl_size
+ !> number of particles in a block boundary wich used a specific remeshing formula
+ !! which is related to the stencil width.
+ integer, public :: bl_bound_size
+ !> Number of block on each processus along each direction
+ integer, dimension(3), public :: bl_number
+
+ ! ------ To ensure unique mpi message tag -----
+ ! Tag generate with a proc_gap
+ !> To create tag used in AC_particle_velocity to send range
+ integer, dimension(2) :: tag_velo_range = (/ 0,1 /)
+ !> To create tag used in AC_particle_velocity to send velocity field
+ integer, dimension(2) :: tag_velo_V = (/ 0,2 /)
+ !> To create tag used in bufferToScalar to send range of buffer which will be send
+ integer, dimension(2) :: tag_bufToScal_range = (/ 0,3 /)
+ !> To create tag used in bufferToScalar to send the buffer used to remesh particles
+ integer, dimension(2) :: tag_bufToScal_buffer = (/ 0,4 /)
+
+ ! Tag generate with "compute_gap_NP"
+ !> To create tag used in AC_obtain_recevers to send ghost
+ integer, dimension(2) :: tag_obtrec_ghost_NP = (/ 0, 1/)
+ !> To create tag used in AC_type_and_bloc to exchange ghost with neighbors
+ integer, dimension(2) :: tag_part_tag_NP = (/ 0, 2/)
+ !> To create tag used in AC_obtain_recevers to send message about recevers of minimal and maximal rank
+ integer, dimension(2) :: tag_obtrec_NP = (/ 0, 3/)
+ !> To create tag used in AC_obtain_receivers to send message about senders of minimal and maximal rank
+ integer, dimension(2) :: tag_obtsend_NP = (/ 0, 4/)
+
+
+
+
+
+
+ ! ===== Public procedures =====
+ character(len=str_short), public :: type_solv
+ !public :: tag_particles_O2
+ !----- Determine block type and tag particles -----
+ public :: AC_type_and_block
+ !----- To interpolate velocity -----
+ public :: AC_obtain_receivers
+ public :: AC_particle_velocity
+ !----- To remesh particles -----
+ public :: AC_obtain_senders
+ public :: AC_bufferToScalar
+ !----- Order 2 remeshing formula -----
+ public :: AC_remesh_left ! left remeshing formula
+ public :: AC_remesh_center ! centered remeshing formula
+ public :: AC_remesh_tag_CL ! corrected formula for tagged particles : transition from C to L block.
+ public :: AC_remesh_tag_LC ! corrected formula for tagged particles : transition from L to C block
+
+
+ contains
+
+! ===== Public procedure =====
+
+! XXX Subroutine à mettre à jour
+! eps_bl=d_sc/10.0
+! cfl = dt/d_sc
+!
+! bl_nb_part = 0
+! bl_final_ind = 0
+! bl_lambdaMin = maxval(p_V)*cfl ! or any big value. We can perhaps used
+! ! the cfl condition from the NS solver
+!
+!
+! deallocate(bl_nb_part)
+! deallocate(bl_final_ind)
+! deallocate(bl_lambdaMin)
+! deallocate(bl_ind)
+! deallocate(bl_type)
+!
+!end subroutine tag_particles_O2
+
+! ==================================================================================
+! ==================== Compute particle velocity (RK2) ====================
+! ==================================================================================
+
+!> Interpolate the velocity field used in a RK2 scheme for particle advection.
+!! @param[in] dt = time step
+!! @param[in] direction = current direction (1 = along X, 2 = along Y and 3 = along Z)
+!! @param[in] comm = mpi communicator associated to the current direction (Y_comm, Z_comm)
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_pos_adim = adimensionned particle postion
+!! @param[in,out] p_V = particle velocity (along the current direction)
+!! @details
+!! A RK2 scheme is used to advect the particles : the midlle point scheme. An
+!! intermediary position "p_pos_bis(i) = p_pos(i) + V(i)*dt/2" is computed and then
+!! the numerical velocity of each particles is computed as the interpolation of V in
+!! this point. This field is used to advect the particles at the seconde order in time :
+!! p_pos(t+dt, i) = p_pos(i) + p_V(i).
+!! The group line indice is used to ensure using unicity of each mpi message tag.
+subroutine AC_particle_velocity(dt, direction, comm, ind_group, p_pos_adim, p_V)
+
+ ! This code involve a recopy of p_V. It is possible to directly use the 3D velocity field but in a such code
+ ! a memory copy is still needed to send velocity field to other processus : mpi send contiguous memory values
+
+ use mpi
+ use cart_topology
+
+ ! --- In order to create an arry of pointer ---
+ type real_pter
+ real(WP), pointer :: pter
+ end type real_pter
+ ! ---------------------------------------------
+
+ real(WP), intent(in) :: dt ! time step
+ integer, intent(in) :: direction
+ integer, intent(in) :: comm
+ integer, dimension(2), intent(in) :: ind_group
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ real(WP), dimension(:), intent(inout) :: p_V
+
+ real(WP), dimension(N_proc(direction)) :: p_pos_bis ! adimensionned position of the middle point
+ real(WP), dimension(N_proc(direction)), target :: p_V_bis ! velocity of the middle point
+ real(WP), dimension(N_proc(direction)) :: weight ! interpolation weight
+ type(real_pter), dimension(N_proc(direction)) :: Vp, Vm ! Velocity on previous and next mesh point
+ real(WP), dimension(:), allocatable, target :: V_buffer ! Velocity buffer for postion outside of the local subdomain
+ integer :: size_buffer ! buffer size
+ integer :: temp ! use in some computations
+ integer :: rece_ind_min ! the minimal indice used in velocity interpolation
+ integer :: rece_ind_max ! the maximal indice used in velocity interpolation
+ integer :: ind, ind_com ! indices
+ integer :: pos, pos_old ! indices of the mesh point wich preceed the particle position
+ integer :: proc_gap, gap! distance between my (mpi) coordonate and coordinate of the
+ ! processus associated to a given position
+ integer, dimension(:), allocatable :: rece_rank ! rank of processus wich send me information
+ integer :: send_rank ! rank of processus to wich I send information
+ integer :: rankP ! rank of processus ("source rank" returned by mpi_cart_shift)
+ integer, dimension(2) :: rece_range ! range of the velocity fields I want to receive
+ integer, dimension(2) :: send_range ! range of the velocity fields I send
+ integer, dimension(2) :: rece_gap ! distance between me and processus wich send me information
+ integer, dimension(2) :: send_gap ! distance between me and processus to wich I send information
+ integer :: msg_size ! size of message send/receive
+ integer :: tag ! mpi message tag
+ integer :: ierr ! mpi error code
+ integer :: send_request ! mpi communication request (handle) of nonblocking send
+! XXX debug - to delete XXX
+ integer, dimension(:), allocatable :: s_request ! mpi communication request (handle) of nonblocking send
+ integer, dimension(:), allocatable :: s_request_bis! mpi communication request (handle) of nonblocking send
+! XXX end debug XXX
+ integer, dimension(:), allocatable :: rece_request ! mpi communication request (handle) of nonblocking receive
+ integer, dimension(MPI_STATUS_SIZE) :: rece_status ! mpi status (for mpi_wait)
+
+ ! -- Initialisation --
+ ind_com = 0
+ do ind = 1, N_proc(direction)
+ nullify(Vp(ind)%pter)
+ nullify(Vm(ind)%pter)
+ end do
+ ! Compute the midlle point
+ p_pos_bis = p_pos_adim + (dt/2.0)*p_V/d_sc(direction)
+ p_V_bis = p_V
+ ! Compute range of the set of point where I need the velocity value
+ rece_ind_min = floor(p_pos_bis(1))
+ rece_ind_max = floor(p_pos_bis(N_proc(direction))) + 1
+ ! Allocate the buffer
+ ! If rece_ind_min and rece_ind_max are not in [N_proc(direction);1] then it will change the number of communication
+ ! size_buffer = max(temp - N_proc(direction), 0) - min(0, temp)
+ !size_buffer = - max(temp - N_proc(direction), 0) - min(0, temp)
+ ! It must work, but for first test we prefer compute size_buffer more simply
+ size_buffer = 0
+
+ ! -- Exchange non blocking message to do the computations during the
+ ! communication process
+ call AC_obtain_receivers(direction, comm, ind_group, rece_ind_min, rece_ind_max, send_gap, rece_gap)
+ allocate(rece_rank(rece_gap(1):rece_gap(2)))
+ ! Send messages about what I want
+! XXX debug - to delete XXX
+ allocate(s_request_bis(rece_gap(1):rece_gap(2)))
+! XXX end debug XXX
+ do proc_gap = rece_gap(1), rece_gap(2)
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, rece_rank(proc_gap), ierr)
+ if (rece_rank(proc_gap) /= myrank) then
+ ! Range I want
+ gap = proc_gap*N_proc(direction)
+ rece_range(1) = max(rece_ind_min, gap+1) ! fortran => indice start from 0
+ rece_range(2) = min(rece_ind_max, gap+N_proc(direction))
+ ! Tag = concatenation of (rank+1), ind_group(1), ind_group(2), direction et unique Id.
+ tag = compute_tag(ind_group, tag_velo_range, direction, proc_gap)
+ ! Send message
+ size_buffer = size_buffer + (rece_range(2)-rece_range(1)) + 1
+! XXX debug - to delete XXX
+ call mpi_Isend(rece_range(1), 2, MPI_INTEGER, rece_rank(proc_gap), tag, comm, s_request_bis(proc_gap), ierr)
+! XXX debug - uncomment the following line XXX
+! call mpi_Isend(rece_range(1), 2, MPI_INTEGER, rece_rank(proc_gap), tag, comm, send_request, ierr)
+! XXX end debug XXX
+ end if
+ end do
+ allocate(V_buffer(max(size_buffer,1)))
+ V_buffer = 0
+ ! Send the velocity field to processus which need it
+! XXX debug - to delete XXX
+ allocate(s_request(send_gap(1):send_gap(2)))
+! XXX end debug XXX
+ do proc_gap = send_gap(1), send_gap(2)
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank /= myrank) then
+ ! I - Receive messages about what I have to send
+ ! Ia - Compute reception tag = concatenation of (rank+1), ind_group(1), ind_group(2), direction et unique Id.
+ tag = compute_tag(ind_group, tag_velo_range, direction, -proc_gap)
+ ! Ib - Receive the message
+ call mpi_recv(send_range(1), 2, MPI_INTEGER, send_rank, tag, comm, rece_status, ierr)
+ send_range = send_range + proc_gap*N_proc(direction)
+ ! II - Send it
+ ! IIa - Compute send tag
+ tag = compute_tag(ind_group, tag_velo_V, direction, proc_gap)
+ ! IIb - Send message
+! XXX debug - to delete XXX
+ call mpi_Isend(p_V(send_range(1)), send_range(2)-send_range(1)+1, MPI_DOUBLE_PRECISION, &
+ & send_rank, tag, comm, s_request(proc_gap), ierr)
+! XXX debug - uncomment the two following line XXX
+! call mpi_Isend(p_V(send_range(1)), send_range(2)-send_range(1)+1, MPI_DOUBLE_PRECISION, &
+! & send_rank, tag, comm, send_request, ierr)
+! XXX end debug XXX
+ end if
+ end do
+
+ ! Non blocking reception of the velocity field
+ ind = 1
+ allocate(rece_request(rece_gap(1):rece_gap(2)))
+ do proc_gap = rece_gap(1), rece_gap(2)
+ if (rece_rank(proc_gap) /= myrank) then
+ ! IIa - Compute reception tag
+ tag = compute_tag(ind_group, tag_velo_V, direction, -proc_gap)
+ ! IIb - Receive message
+ rece_range(1) = max(rece_ind_min, gap+1) ! fortran => indice start from 0
+ rece_range(2) = min(rece_ind_max, gap+N_proc(direction))
+ msg_size = rece_range(2)-rece_range(1)+1
+ call mpi_Irecv(V_buffer(ind), msg_size, MPI_DOUBLE_PRECISION, rece_rank(proc_gap), tag, comm, &
+ & rece_request(proc_gap), ierr)
+ ind = ind + msg_size
+ end if
+ end do
+
+ ! -- Compute the interpolated velocity
+ ! Compute the interpolation weight and update the pointers Vp and Vm
+ ! Initialisation of reccurence process
+ ind = 1
+ pos = floor(p_pos_bis(ind))
+ weight(ind) = p_pos_bis(ind)-pos
+ ! Vm = V(pos)
+ proc_gap = floor(real((pos-1)/N_proc(direction)))
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank == myrank) then
+ Vm(ind)%pter => p_V_bis(pos-proc_gap*N_proc(direction))
+ else
+ ind_com = ind_com + 1
+ Vm(ind)%pter => V_buffer(ind_com)
+ end if
+ ! Vp = V(pos+1)
+ proc_gap = floor(real((pos+1-1)/N_proc(direction)))
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank == myrank) then
+ Vp(ind)%pter => p_V_bis(pos+1-proc_gap*N_proc(direction))
+ else
+ ind_com = ind_com + 1
+ Vp(ind)%pter => V_buffer(ind_com)
+ end if
+ pos_old = pos
+
+ ! Following indice : we use previous work (already done)
+ do ind = 2, N_proc(direction)
+ pos = floor(p_pos_bis(ind))
+ weight(ind) = p_pos_bis(ind)-pos
+ select case(pos-pos_old)
+ case(0)
+ ! The particle belongs to the same segment than the previous one
+ Vm(ind)%pter => Vm(ind-1)%pter
+ Vp(ind)%pter => Vp(ind-1)%pter
+ case(1)
+ ! The particle follows the previous one
+ Vm(ind)%pter => Vp(ind-1)%pter
+ ! Vp = V(pos+1)
+ proc_gap = floor(real((pos+1-1)/N_proc(direction))) ! fortran -> indice starts from 1
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank == myrank) then
+ Vp(ind)%pter => p_V_bis(pos+1-proc_gap*N_proc(direction))
+ else
+ ind_com = ind_com + 1
+ Vp(ind)%pter => V_buffer(ind_com)
+ end if
+ case(2)
+ ! pos = pos_old +2, wich correspond to "extention"
+ ! Vm = V(pos)
+ proc_gap = floor(real((pos-1)/N_proc(direction)))
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank == myrank) then
+ Vm(ind)%pter => p_V_bis(pos-proc_gap*N_proc(direction))
+ else
+ ind_com = ind_com + 1
+ Vm(ind)%pter => V_buffer(ind_com)
+ end if
+ ! Vp = V(pos+1)
+ proc_gap = floor(real((pos+1-1)/N_proc(direction)))
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank == myrank) then
+ Vp(ind)%pter => p_V_bis(pos+1-proc_gap*N_proc(direction))
+ else
+ ind_com = ind_com + 1
+ Vp(ind)%pter => V_buffer(ind_com)
+ end if
+ case default
+ print*, "unexpected case : pos = ", pos, " , pos_old = ", pos_old, " ind = ", ind
+ end select
+ pos_old = pos
+ end do
+
+ ! -- Compute the interpolate velocity --
+ ! Check if communication are done
+ do proc_gap = rece_gap(1), rece_gap(2)
+ if (rece_rank(proc_gap)/=myrank) then
+ call mpi_wait(rece_request(proc_gap), rece_status, ierr)
+ end if
+ end do
+
+
+ ! Then compute the field
+ do ind = 1, N_proc(direction)
+ p_V(ind) = weight(ind)*Vp(ind)%pter + (1-weight(ind))*Vm(ind)%pter
+ end do
+
+! XXX debug - to delete XXX
+ do ind = 1, N_proc(direction)
+ nullify(Vp(ind)%pter)
+ nullify(Vm(ind)%pter)
+ end do
+
+ do proc_gap = send_gap(1), send_gap(2)
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ if (send_rank /= myrank) then
+ call MPI_WAIT(s_request(proc_gap),rece_status,ierr)
+ end if
+ end do
+ deallocate(s_request)
+ do proc_gap = rece_gap(1), rece_gap(2)
+ if (rece_rank(proc_gap) /= myrank) then
+ call MPI_WAIT(s_request_bis(proc_gap),rece_status,ierr)
+ end if
+ end do
+ deallocate(s_request_bis)
+! XXX end debug XXX
+
+ ! Deallocation
+ deallocate(rece_rank)
+ deallocate(rece_request)
+ deallocate(V_buffer)
+
+end subroutine AC_particle_velocity
+
+
+!> Determine the set of processes wich will send me information during the velocity interpolation.
+!! @param[in] direction = current direction (1 = along X, 2 = along Y, 3 = along Z)
+!! @param[in] comm = mpi communicator associated with the current direction
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] rece_ind_min = minimal indice of mesh involved in remeshing particles (of the my local subdomains)
+!! @param[in] rece_ind_max = maximal indice of mesh involved in remeshing particles (of the my local subdomains)
+!! @param[out] send_gap = gap between my coordinate and the processes of minimal coordinate which will send information to me
+!! @param[out] rece_gap = gap between my coordinate and the processes of maximal coordinate which will receive information from me
+!! @details
+!! Obtain the list of processus wich need a part of my local velocity field
+!! to interpolate the velocity used in the RK2 scheme to advect its particles.
+subroutine AC_obtain_receivers(direction, comm, ind_group, rece_ind_min, rece_ind_max, send_gap, rece_gap)
+! XXX Work only for periodic condition.
+
+ use cart_topology
+ use mpi
+
+ integer, intent(in) :: rece_ind_min, rece_ind_max
+ integer, intent(in) :: direction, comm
+ integer, dimension(2), intent(in) :: ind_group
+ integer, dimension(2), intent(out) :: rece_gap, send_gap
+ integer, dimension(MPI_STATUS_SIZE) :: statut
+
+ integer :: proc_gap ! gap between a processus coordinate (along the current
+ ! direction) into the mpi-topology and my coordinate
+ integer :: rece_gapP ! gap between the coordinate of the previous processus (in the current direction)
+ ! and the processes of maximal coordinate which will receive information from it
+ integer :: rece_gapN ! same as above but for the next processus
+ integer :: rankP, rankN ! processus rank for shift (P= previous, N = next)
+ integer :: tag_min, tag_max ! mpi message tag (for communicate rece_proc(1) and rece_proc(2))
+ integer :: send_request ! mpi status of nonblocking send
+ integer :: send_request_bis ! mpi status of nonblocking send
+ integer :: ierr ! mpi error code
+ integer :: tag ! mpi message tag
+ integer, dimension(2) :: tag_table ! some mpi message tag
+! XXX debug - to delete XXX
+ integer :: pr
+ logical, dimension(:,:), allocatable:: test_request
+ integer, dimension(:,:), allocatable:: s_request
+! XXX end debug XXX
+
+ tag_min = 5
+ tag_max = 6
+
+ send_gap = 3*N(direction)
+
+ rece_gap(1) = floor(real(rece_ind_min-1)/N_proc(direction))
+ rece_gap(2) = floor(real(rece_ind_max-1)/N_proc(direction))
+
+ ! Communicate with my neigbors
+ ! Compute their rank
+ call mpi_cart_shift(cart_comm, (direction-1), 1, rankP, rankN, ierr)
+ ! Inform that about processus from which I need information
+ tag_table = compute_tag(ind_group, tag_obtrec_ghost_NP, direction)
+ call mpi_Isend(rece_gap(1), 1, MPI_INTEGER, rankP, tag_table(1), comm, send_request, ierr)
+ call mpi_Isend(rece_gap(2), 1, MPI_INTEGER, rankN, tag_table(2), comm, send_request_bis, ierr)
+ ! Receive the same message form my neighbors
+ call mpi_recv(rece_gapN, 1, MPI_INTEGER, rankN, tag_table(1), comm, statut, ierr)
+ call mpi_recv(rece_gapP, 1, MPI_INTEGER, rankP, tag_table(2), comm, statut, ierr)
+
+
+ ! Send
+! XXX debug - to delete XXX
+ allocate(s_request(rece_gap(1):rece_gap(2),2))
+ allocate(test_request(rece_gap(1):rece_gap(2),2))
+ test_request = .false.
+! XXX end debug XXX
+ do proc_gap = rece_gap(1), rece_gap(2)
+ ! Compute the rank of the target processus
+ call mpi_cart_shift(cart_comm, (direction-1), proc_gap, rankP, rankN, ierr)
+ ! Determine if I am the the first or the last processes (considering the current directory)
+ ! to require information from this processus
+ if (proc_gap>rece_gapP-1) then
+ if(rankN /= myrank) then
+ tag_table = compute_tag(ind_group, tag_obtrec_NP, direction)
+! XXX debug - to delete XXX
+ call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(1), comm, s_request(proc_gap,1), ierr)
+ test_request(proc_gap,1) = .true.
+! XXX uncomment following line XXX
+! call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(1), comm, send_request, ierr)
+! XXX end debug XXX
+ else
+ send_gap(1) = -proc_gap
+ end if
+ end if
+ if (proc_gap<rece_gapN+1) then
+ if(rankN /= myrank) then
+! XXX debug - to delete XXX
+ test_request(proc_gap,2) = .true.
+ call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(2), comm, s_request(proc_gap,2), ierr)
+! XXX uncomment following line XXX
+! call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(2), comm, send_request_bis, ierr)
+! XXX end debug XXX
+ else
+ send_gap(2) = -proc_gap
+ end if
+ end if
+ end do
+
+
+ ! Receive
+ if (send_gap(1) == 3*N(direction)) then
+ call mpi_recv(send_gap(1), 1, MPI_INTEGER, MPI_ANY_SOURCE, tag_table(1), comm, statut, ierr)
+ end if
+ if (send_gap(2) == 3*N(direction)) then
+ call mpi_recv(send_gap(2), 1, MPI_INTEGER, MPI_ANY_SOURCE, tag_table(2), comm, statut, ierr)
+ end if
+
+
+! XXX debug - to delete XXX
+ call MPI_WAIT(send_request,statut,ierr)
+ call MPI_WAIT(send_request_bis,statut,ierr)
+ do proc_gap = rece_gap(1), rece_gap(2)
+ if (test_request(proc_gap,1).eqv. .true.) call MPI_WAIT(s_request(proc_gap,1),statut,ierr)
+ if (test_request(proc_gap,2)) call MPI_WAIT(s_request(proc_gap,2),statut,ierr)
+ end do
+ deallocate(s_request)
+ deallocate(test_request)
+! XXX end debug XXX
+
+end subroutine AC_obtain_receivers
+
+
+! ===================================================================================================
+! ==================== Others than velocity interpolation and remeshing ====================
+! ===================================================================================================
+
+!> Determine type (center or left) of each block and tag particle to know where
+!! corrected remeshing formula are recquired.
+!! @param[in] dt = time step
+!! @param[in] direction = current direction (1 = along X, 2 = along Y and 3 = along Z)
+!! @param[in] comm = mpi communicator associated to the current direction (Y_comm, Z_comm)
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] p_V = particle velocity (along the current direction)
+!! @param[out] bl_type = table of blocks type (center of left)
+!! @param[out] bl_tag = inform about tagged particles (bl_tag(ind_bl)=1 if the end of the bl_ind-th block
+!! and the begining of the following one is tagged)
+subroutine AC_type_and_block(dt, direction, comm, ind_group, p_V, &
+ & bl_type, bl_tag)
+
+ use mpi
+ use cart_topology
+ use precision
+
+ real(WP), intent(in) :: dt ! time step
+ integer, intent(in) :: direction
+ integer, intent(in) :: comm
+ integer, dimension(2), intent(in) :: ind_group
+ real(WP), dimension(:), intent(in) :: p_V
+ integer, dimension(bl_number(direction)+1), intent(out) :: bl_type ! is the particle block a center block or a left one ?
+ integer, dimension(bl_number(direction)), intent(out) :: bl_tag ! indice of tagged particles
+
+ real(WP), dimension(bl_number(direction)+1) :: bl_lambdaMin ! for a particle, lamda = V*dt/dx ; bl_lambdaMin = min of
+ ! lambda on a block (take also into account first following particle)
+ real(WP) :: lambP, lambN ! buffer to exchange some lambda min with other processus
+ integer, dimension(bl_number(direction)+1) :: bl_ind ! block index : integer as lambda in (bl_ind,bl_ind+1) for a left block
+ ! and lambda in (bl_ind-1/2, bl_ind+1/2) for a right block
+ integer :: ind, ind2,i_p! some indices
+ real(WP) :: cfl ! = d_sc
+ integer :: rankP, rankN ! processus rank for shift (P= previous, N = next)
+ integer, dimension(2) :: send_request ! mpi status of nonblocking send
+ integer, dimension(2) :: rece_request ! mpi status of nonblocking receive
+ integer, dimension(MPI_STATUS_SIZE) :: rece_status ! mpi status (for mpi_wait)
+ integer :: tag ! tag for mpi message
+ integer, dimension(2) :: tag_table ! other tags for mpi message
+ integer :: ierr ! mpi error code
+
+ ! ===== Initialisation =====
+ cfl = dt/d_sc(direction)
+
+ ! ===== Compute bl_lambdaMin =====
+ ! -- Compute rank of my neighbor --
+ call mpi_cart_shift(cart_comm, (direction-1), 1, rankP, rankN, ierr)
+
+ ! -- For the first block (1/2) --
+ ! The domain contains only its second half => exchange ghost with the previous processus
+ bl_lambdaMin(1) = p_V(1)*cfl
+ do i_p = 2, (bl_size/2)+1
+ bl_lambdaMin(1) = min(bl_lambdaMin(1), p_V(i_p)*cfl)
+ end do
+ tag_table = compute_tag(ind_group, tag_part_tag_NP, direction)
+ ! Send message
+ call mpi_Isend(bl_lambdaMin(1), 1, MPI_DOUBLE_PRECISION, rankP, tag_table(1), comm, send_request(1), ierr)
+ ! Receive it
+ call mpi_Irecv(lambN, 1, MPI_DOUBLE_PRECISION, rankN, tag_table(1), comm, rece_request(1), ierr)
+
+ ! -- For the last block (1/2) --
+ ! The processus contains only its first half => exchange ghost with the next processus
+ ind = bl_number(direction) + 1
+ bl_lambdaMin(ind) = p_V(N_proc(direction))*cfl
+ do i_p = N_proc(direction) - (bl_size/2)+2, N_proc(direction)-1
+ bl_lambdaMin(ind) = min(bl_lambdaMin(ind), p_V(i_p)*cfl)
+ end do
+ ! Send message
+ call mpi_Isend(bl_lambdaMin(ind), 1, MPI_DOUBLE_PRECISION, rankN, tag_table(2), comm, send_request(2), ierr)
+ ! Receive it
+ call mpi_Irecv(lambP, 1, MPI_DOUBLE_PRECISION, rankP, tag_table(2), comm, rece_request(2), ierr)
+
+ ! -- For the "middle" block --
+ do ind = 2, bl_number(direction)
+ i_p = ((ind-1)*bl_size) + 1 - bl_size/2
+ bl_lambdaMin(ind) = p_V(i_p)*cfl
+ do ind2 = 2, bl_size+1
+ i_p = ((ind-1)*bl_size) + ind2 - bl_size/2
+ bl_lambdaMin(ind) = min(bl_lambdaMin(ind), p_V(i_p)*cfl)
+ end do
+ end do
+
+ ! -- For the first block (1/2) --
+ ! The domain contains only its second half => use exchanged ghost
+ ! Check reception
+ call mpi_wait(rece_request(2), rece_status, ierr)
+ bl_lambdaMin(1) = min(bl_lambdaMin(1), lambP)
+
+ ! -- For the last block (1/2) --
+ ! The processus contains only its first half => use exchanged ghost
+ ! Check reception
+ call mpi_wait(rece_request(1), rece_status, ierr)
+ ind = bl_number(direction) + 1
+ bl_lambdaMin(ind) = min(bl_lambdaMin(ind), lambN)
+
+ ! ===== Compute block type and index =====
+ do ind = 1, bl_number(direction) + 1
+ bl_ind(ind) = nint(bl_lambdaMin(ind))
+ if (bl_lambdaMin(ind)<bl_ind(ind)) then
+ ! => center type
+ bl_type(ind) = 1
+ else
+ ! => left type
+ bl_type(ind) = 0
+ end if
+ end do
+
+ ! ===== Tag particles =====
+
+ do ind = 1, bl_number(direction)
+ if ((bl_ind(ind)/=bl_ind(ind+1)) .and. (bl_type(ind)/=bl_type(ind+1))) then
+ ! the end of ind-th block and the beginning of the following one are tagged
+ bl_tag(ind) = 1
+ else
+ bl_tag(ind) = 0
+ end if
+ end do
+
+end subroutine AC_type_and_block
+
+
+! ===================================================================
+! ==================== Remesh particles ====================
+! ===================================================================
+
+!> Determine the set of processes wich will send me information during the
+!! scalar remeshing.
+!! @param[in] send_j_min = minimal indice of mesh involved in remeshing particles (of the particles in my local subdomains)
+!! @param[in] send_j_max = maximal indice of mesh involved in remeshing particles (of the particles in my local subdomains)
+!! @param[in] direction = current direction (1 = along X, 2 = along Y, 3 = along Z)
+!! @param[in] comm = mpi communicator associated with the current direction
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[out] proc_min = gap between my coordinate and the processes of minimal coordinate which will receive information from me
+!! @param[out] proc_max = gap between my coordinate and the processes of maximal coordinate which will receive information from me
+!! @param[out] rece_proc = coordinate range of processes which will send me information during the remeshing.
+!! @details
+!! Obtain the list of processus which contains some particles which belong to
+!! my subdomains after their advection (and thus which will be remeshing into
+!! my subdomain). This result is return as an interval [send_min; send_max].
+!! All the processus whose coordinate (into the current direction) belong to
+!! this segment are involved into scalar remeshing into the current
+!! subdomains.
+subroutine AC_obtain_senders(send_j_min, send_j_max, direction, comm, ind_group, proc_min, proc_max, rece_proc)
+! XXX Work only for periodic condition. For dirichlet conditions : it is
+! possible to not receive either rece_proc(1), either rece_proc(2) or none of
+! these two => detect it (track the first and the last particles) and deal with it.
+
+ use cart_topology
+ use mpi
+
+ integer, intent(in) :: send_j_min, send_j_max
+ integer, intent(in) :: direction, comm
+ integer, dimension(2), intent(in) :: ind_group
+ integer(kind=4), intent(out) :: proc_min, proc_max
+ integer, dimension(2), intent(out) :: rece_proc
+ integer, dimension(MPI_STATUS_SIZE) :: statut
+
+ integer(kind=4) :: proc_gap ! gap between a processus coordinate (along the current
+ ! direction) into the mpi-topology and my coordinate
+ integer :: rankP, rankN ! processus rank for shift (P= previous, N = next)
+ integer, dimension(2) :: tag_table ! mpi message tag (for communicate rece_proc(1) and rece_proc(2))
+ integer :: send_request ! mpi status of nonblocking send
+ integer :: ierr ! mpi error code
+
+ tag_table = compute_tag(ind_group, tag_obtsend_NP, direction)
+
+ rece_proc = 3*N(direction)
+
+ proc_min = floor(real(send_j_min-1)/N_proc(direction))
+ proc_max = floor(real(send_j_max-1)/N_proc(direction))
+
+ ! Send
+ do proc_gap = proc_min, proc_max
+ ! Compute the rank of the target processus
+ call mpi_cart_shift(cart_comm, (direction-1), proc_gap, rankP, rankN, ierr)
+ ! Determine if I am the the first or the last processes (considering my
+ ! coordinate along the current directory) to send information to
+ ! one of these processes.
+ ! Note that local indice go from 1 to N_proc (fortran).
+ ! I am the first ?
+ if ((send_j_min< +1-2*bl_bound_size + proc_gap*N_proc(direction)+1).AND. &
+ & (send_j_max>= proc_gap*N_proc(direction))) then
+ if(rankN /= myrank) then
+ call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(1), comm, send_request, ierr)
+ else
+ rece_proc(1) = -proc_gap
+ end if
+ end if
+ ! I am the last ?
+ if ((send_j_max > -1+2*bl_bound_size + (proc_gap+1)*N_proc(direction)) &
+ & .AND.(send_j_min<= (proc_gap+1)*N_proc(direction))) then
+ if(rankN /= myrank) then
+ call mpi_Isend(-proc_gap, 1, MPI_INTEGER, rankN, tag_table(2), comm, send_request, ierr)
+ else
+ rece_proc(2) = -proc_gap
+ end if
+ end if
+ end do
+
+
+ ! Receive
+ if (rece_proc(1) == 3*N(direction)) then
+ call mpi_recv(rece_proc(1), 1, MPI_INTEGER, MPI_ANY_SOURCE, tag_table(1), comm, statut, ierr)
+ end if
+ if (rece_proc(2) == 3*N(direction)) then
+ call mpi_recv(rece_proc(2), 1, MPI_INTEGER, MPI_ANY_SOURCE, tag_table(2), comm, statut, ierr)
+ end if
+
+end subroutine AC_obtain_senders
+
+!> Common procedure for remeshing wich perform all the communcation and provide
+!! the update scalar field.
+!! @param[in] direction = current direction (1 = along X, 2 = along Y and 3 = along Z)
+!! @param[in] comm = mpi communicator associated to the current direction (Y_comm, Z_comm)
+!! @param[in] ind_group = coordinate of the current group of lines
+!! @param[in] send_i_min = minimal indice of the send buffer
+!! @param[in] send_i_max = maximal indice of the send buffer
+!! @param[in] send_buffer = buffer use to remesh the scalar before to send it to the right subdomain
+!! @param[in,out] scal1D = mono-dimensionnal scalar field to advect
+!! (XXX todo : decide if extraction from the 3D or pointeur)
+!! @details
+!! Remeshing are done in a local buffer. This subroutine distribute this buffer
+!! to the right processes, receive the buffer send and update the scalar field.
+subroutine AC_bufferToScalar(direction, comm, ind_group, send_i_min, send_i_max, send_buffer, scal1D)
+
+ use cart_topology
+ use mpi
+
+ integer, intent(in) :: direction
+ integer, intent(in) :: comm
+ integer, dimension(2), intent(in) :: ind_group
+ integer, intent(in) :: send_i_min
+ integer, intent(in) :: send_i_max
+ real(WP), dimension(send_i_min:send_i_max), intent(in) :: send_buffer
+ !XXX - ca ne devrait pas bugger sans les range
+ real(WP), dimension(N_proc(direction)), intent(inout) :: scal1D
+
+! XXX todo vrai scalaire = 3D -> choisir si on envoie un sous-tableau 1D du
+! scalaire ou un tableau de pointeur 1D qui pointe vers les bonnes cases du
+! champ scalaire
+
+ ! Variables used to communicate between subdomains. A variable prefixed by "send_"(resp "rece")
+ ! design something I send (resp. I receive).
+ integer :: i ! table indice
+ integer :: proc_gap ! gap between my Y-coordinate and the one of the processus
+ integer, dimension(2) :: rece_proc ! minimal and maximal gap between my Y-coordinate and the one from which
+ ! I will receive data
+ integer :: proc_min ! smaller gap between me and the processes to where I send data
+ integer :: proc_max ! smaller gap between me and the processes to where I send data
+ real(WP), dimension(:), allocatable :: rece_buffer ! buffer use to stock received scalar field
+ integer :: send_gap ! number of mesh between my and another processus
+ integer,dimension(:,:), allocatable :: rece_range ! range of (local) indice where the received scalar field has to be save
+ integer, dimension(2) :: send_range ! range of (local) indice where the send scalar field has to be save
+ integer, dimension(:), allocatable :: rece_request ! mpi communication request (handle) of nonblocking receive
+ integer, dimension(:), allocatable :: rece_rank ! rank of processus from wich I receive data
+ integer :: send_rank ! rank of processus to which I send data
+ integer :: rankP ! rank used in mpi_cart_shift
+ integer, dimension(MPI_STATUS_SIZE) :: rece_status ! mpi status (for mpi_wait)
+ integer :: send_request ! mpi status of nonblocking send
+ integer :: rece_i_min ! the minimal indice from where belong the scalar field I receive
+ integer :: rece_i_max ! the maximal indice from where belong the scalar field I receive
+ integer :: ierr ! mpi error code
+ integer :: comm_size ! number of element to send/receive
+ integer :: tag ! mpi message tag
+ ! with wich I communicate.
+
+
+ ! Determine the communication needed : who will communicate whit who ? (ie compute sender and recer)
+ call AC_obtain_senders(send_i_min, send_i_max, direction, comm, ind_group, proc_min, proc_max, rece_proc)
+ ! Send the information
+ do proc_gap = proc_min, proc_max
+ ! Compute the rank of the target processus
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, send_rank, ierr)
+ send_gap = proc_gap*N_proc(direction)
+ send_range(1) = max(send_i_min, send_gap+1) ! fortran => indice start from 0
+ send_range(2) = min(send_i_max, send_gap+N_proc(direction))
+ if (send_rank/=myrank) then
+ ! Determine quantity of information to send
+ comm_size = send_range(2)-send_range(1)+1
+ ! Send the range of the scalar field send
+ tag = compute_tag(ind_group, tag_bufToScal_range, direction, proc_gap)
+ call mpi_Isend(send_range(1), 2, MPI_INTEGER, send_rank, tag, comm, send_request, ierr)
+ ! And send the buffer
+ tag = compute_tag(ind_group, tag_bufToScal_buffer, direction, proc_gap)
+ call mpi_Isend(send_buffer(send_range(1)),comm_size, MPI_DOUBLE_PRECISION, send_rank, &
+ & tag, comm, send_request, ierr)
+ else
+ ! I have to distribute the buffer in myself
+ do i = send_range(1), send_range(2)
+ scal1D(i-send_gap) = scal1D(i-send_gap) + send_buffer(i)
+ end do
+ end if
+ end do
+
+ ! Receive information
+ ! Allocate field
+ allocate(rece_rank(rece_proc(1):rece_proc(2)))
+ allocate(rece_range(2,rece_proc(1):rece_proc(2))) ! be careful that mpi use contiguous memory element
+ allocate(rece_request(rece_proc(1):rece_proc(2)))
+ ! Receive range
+ do proc_gap = rece_proc(1), rece_proc(2)
+ call mpi_cart_shift(cart_comm, direction-1, proc_gap, rankP, rece_rank(proc_gap), ierr)
+ if (rece_rank(proc_gap)/=myrank) then
+ tag = compute_tag(ind_group, tag_bufToScal_range, direction, -proc_gap)
+ call mpi_Irecv(rece_range(1,proc_gap), 2, MPI_INTEGER, rece_rank(proc_gap), tag, comm, &
+ & rece_request(proc_gap), ierr) ! we use tag = source rank
+ end if
+ end do
+ ! Check reception
+ do proc_gap = rece_proc(1), rece_proc(2)
+ if (rece_rank(proc_gap)/=myrank) then
+ call mpi_wait(rece_request(proc_gap), rece_status, ierr)
+ end if
+ end do
+ deallocate(rece_request)
+ ! Receive buffer and remesh it
+ ! XXX Possible optimisation : an optimal code will
+ ! 1 - have non-blocking reception of scalar buffers
+ ! 2 - check when a reception is done and then update the scalar
+ ! 3 - iterate step 2 until all message was rece and that the scalar
+ ! field was update with all the scalar buffers
+ do proc_gap = rece_proc(1), rece_proc(2)
+ if (rece_rank(proc_gap)/=myrank) then
+ rece_i_min = rece_range(1,proc_gap)
+ rece_i_max = rece_range(2,proc_gap)
+ ! Receive information
+ comm_size=(rece_i_max-rece_i_min+1)
+ allocate(rece_buffer(rece_i_min:rece_i_max)) ! XXX possible optimisation
+ ! by allocating one time to the max size, note that the range use in
+ ! this allocation instruction is include in (1, N_proc(2))
+ tag = compute_tag(ind_group, tag_bufToScal_buffer, direction, -proc_gap)
+ call mpi_recv(rece_buffer(rece_i_min), comm_size, MPI_DOUBLE_PRECISION, &
+ & rece_rank(proc_gap), tag, Y_comm, rece_status, ierr)
+ ! Update the scalar field
+ send_gap = proc_gap*N_proc(direction)
+ scal1D(rece_i_min+send_gap:rece_i_max+send_gap) = scal1D(rece_i_min+send_gap:rece_i_max+send_gap) &
+ & + rece_buffer(rece_i_min:rece_i_max)
+ deallocate(rece_buffer)
+ end if
+ end do
+
+ deallocate(rece_range)
+ deallocate(rece_rank)
+
+end subroutine AC_bufferToScalar
+
+
+!> Left remeshing formula of order 2
+!! @param[in] pos_adim= adimensionned particle position
+!! @param[in] sca = scalar advected by the particle
+!! @param[in,out] buffer = temporaly remeshed scalar field
+subroutine AC_remesh_left(pos_adim, sca, buffer)
+
+ use cart_topology
+
+ real(WP), intent(in) :: pos_adim, sca
+ real(WP), dimension(send_j_min:send_j_max), intent(inout) :: buffer
+
+ integer :: j0 ! indice of the the nearest mesh points
+ real(WP) :: bM, b0, bP ! interpolation weight for the particles
+ real(WP) :: yM, y0, yP ! adimensionned distance to mesh points
+ ! Mesh point used in remeshing formula
+ j0 = floor(pos_adim)
+ !j0 = floor(pos/d_sc(2))
+
+ ! Distance to mesh points
+ y0 = (pos_adim - float(j0))
+ !y0 = (pos - float(j0)*d_sc(2))/d_sc(2)
+ yM = y0-1
+ yP = y0+1
+
+ ! Interpolation weights
+ bM=0.5*y0*yM
+ b0=1.-y0**2
+ bP=0.5*y0*yP
+
+ ! remeshing
+ buffer(j0-1) = buffer(j0-1) + bM*sca
+ buffer(j0) = buffer(j0) + b0*sca
+ buffer(j0+1) = buffer(j0+1) + bP*sca
+
+end subroutine AC_remesh_left
+
+!> Centered remeshing formula of order 2
+!! @param[in] pos_adim= adimensionned particle position
+!! @param[in] sca = scalar advected by the particle
+!! @param[in,out] buffer = temporaly remeshed scalar field
+subroutine AC_remesh_center(pos_adim, sca, buffer)
+
+ use cart_topology
+
+ real(WP), intent(in) :: pos_adim, sca
+ real(WP), dimension(send_j_min:send_j_max), intent(inout) :: buffer
+
+ integer :: j0 ! indice of the the nearest mesh points
+ real(WP) :: bM, b0, bP ! interpolation weight for the particles
+ real(WP) :: yM, y0, yP ! adimensionned distance to mesh points
+
+ j0 = nint(pos_adim)
+ !j0 = nint(pos/d_sc(2))
+
+ ! Distance to mesh points
+ y0 = (pos_adim - float(j0))
+ !y0 = (pos - float(j0)*d_sc(2))/d_sc(2)
+ yM = y0-1
+ yP = y0+1
+
+ ! Interpolation weights
+ bM=0.5*y0*yM
+ b0=1.-y0**2
+ bP=0.5*y0*yP
+
+ ! remeshing
+ buffer(j0-1) = buffer(j0-1) + bM*sca
+ buffer(j0) = buffer(j0) + b0*sca
+ buffer(j0+1) = buffer(j0+1) + bP*sca
+
+end subroutine AC_remesh_center
+
+
+!> Corrected remeshing formula for transition from Centered block to a Left block with a different indice (tagged particles)
+!! @param[in] pos_adim= adimensionned particle position
+!! @param[in] sca = scalar advected by this particle
+!! @param[in] posP_ad = adimensionned position of the second particle
+!! @param[in] scaP = scalar advected by this particle
+!! @param[in,out] buffer = temporaly remeshed scalar field
+!! @details
+!! Remeshing formula devoted to tagged particles.
+!! The particle group send into argument is composed of a block end and of the
+!! begining of the next block. The first particles belong to a centered block
+!! and the last to a left one. The block have difference indice (tagged
+!! particles) and we have to use corrected formula.
+subroutine AC_remesh_tag_CL(pos_adim, sca, posP_ad, scaP, buffer)
+
+ use cart_topology
+
+ real(WP), intent(in) :: pos_adim, sca, posP_ad, scaP
+ real(WP), dimension(send_j_min:send_j_max), intent(inout) :: buffer
+
+ integer :: jM, j0, jP ! indice of the the nearest mesh points
+ ! (they depend on the block type)
+ integer :: j0_bis ! indice of the the nearest mesh point for the indP=ind+1 particle
+ real(WP) :: aM, a0, bP, b0 ! interpolation weight for the particles
+ real(WP) :: yM, y0, y0_bis, yP_bis ! adimensionned distance to mesh points
+
+ j0 = nint(pos_adim)
+ !j0 = nint(pos/d_sc(2))
+ j0_bis = floor(posP_ad)
+ !j0_bis = floor(posP/d_sc(2))
+ jM=j0-1
+ jP=j0+1
+
+ y0 = (pos_adim - float(j0))
+ !y0 = (pos - float(j0)*d_sc(2))/d_sc(2)
+ y0_bis = (posP_ad - float(j0_bis))
+ !y0_bis = (posP - float(j0_bis)*d_sc(2))/d_sc(2)
+ yM=y0-1.
+ yP_bis=y0_bis+1
+
+ aM=0.5*y0*yM
+ a0=1.-aM
+ bP=0.5*y0_bis*yP_bis
+ b0=1.-bP
+
+ ! Remeshing
+ buffer(jM)=buffer(jM)+aM*sca
+ buffer(j0)=buffer(j0)+a0*sca+b0*scaP
+ buffer(jP)=buffer(jP)+bP*scaP
+
+end subroutine AC_remesh_tag_CL
+
+
+!> Corrected remeshing formula for transition from Left block to a Centered block with a different indice (tagged particles)
+!! @param[in] pos_adim= adimensionned particle position
+!! @param[in] sca = scalar advected by this particle
+!! @param[in] posP_ad = adimensionned position of the second particle
+!! @param[in] scaP = scalar advected by this particle
+!! @param[in,out] buffer = temporaly remeshed scalar field
+!! @details
+!! Remeshing formula devoted to tagged particles.
+!! The particle group send into argument is composed of a block end and of the
+!! begining of the next block. The first particles belong to a left block
+!! and the last to a centered one. The block have difference indice (tagged
+!! particles) and we have to use corrected formula.
+subroutine AC_remesh_tag_LC(pos_adim, sca, posP_ad, scaP, buffer)
+
+ use cart_topology
+
+ real(WP), intent(in) :: pos_adim, sca, posP_ad, scaP
+ real(WP), dimension(send_j_min:send_j_max), intent(inout) :: buffer
+
+ integer :: jM, j0, jP, jP2, jP3 ! indice of the the nearest mesh points
+ ! (they depend on the block type)
+ integer :: j0_bis ! indice of the the nearest mesh point for the indP=ind+1 particle
+ real(WP) :: aM, a0, aP,aP2, b0, bP, bP2, bP3 ! interpolation weight for the particles
+ real(WP) :: yM,y0,yP, yM_bis,y0_bis,yP_bis ! adimensionned distance to mesh points
+
+
+ ! Indice of mesh point used in order to remesh
+ j0 = floor(pos_adim)
+ !j0 = floor(pos/d_sc(2))
+ j0_bis = nint(posP_ad)
+ !j0_bis = nint(posP/d_sc(2))
+ jM=j0-1
+ jP=j0+1
+ jP2=j0+2
+ jP3=j0+3
+
+ ! Distance to mesh point
+ y0 = (pos_adim - float(j0))
+ !y0 = (pos - float(j0)*d_sc(2))/d_sc(2)
+ y0_bis = (posP_ad - float(j0_bis))
+ !y0_bis = (posP - float(j0_bis)*d_sc(2))/d_sc(2)
+ yP=y0+1
+ yM=y0-1
+ yP_bis=y0_bis+1
+ yM_bis=y0_bis-1
+
+ ! Interpolation weight
+ aM=y0*yM/2.
+ a0=1-y0**2
+ aP=y0
+ aP2=y0*yM/2.
+ b0=y0_bis*yP_bis/2.
+ bP=-y0_bis
+ bP2=1-y0_bis**2
+ bP3=y0_bis*yP_bis/2.
+
+ ! Remeshing
+ buffer(jM)= buffer(jM)+aM*sca
+ buffer(j0)= buffer(j0)+a0*sca+b0*scaP
+ buffer(jP)= buffer(jP)+aP*sca+bP*scaP
+ buffer(jP2)=buffer(jP2)+aP2*sca+bP2*scaP
+ buffer(jP3)=buffer(jP3)+bP3*scaP
+
+end subroutine AC_remesh_tag_LC
+
+end module advec_common
+!! @}
diff --git a/CodesEnVrac/LEGI/src/precision.F90 b/CodesEnVrac/LEGI/src/precision.F90
new file mode 100644
index 0000000000000000000000000000000000000000..2a7cd1e0206215da227af6d0c494a1a21df8b515
--- /dev/null
+++ b/CodesEnVrac/LEGI/src/precision.F90
@@ -0,0 +1,27 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: precision
+!
+!> @author
+!> Guillaume Balarac, LEGI
+!
+! DESCRIPTION:
+!> The aim of this module is set some parameters to fix the working data
+!> representation in the code. It is set to double precision for REAL.
+!------------------------------------------------------------------------------
+
+MODULE precision
+ IMPLICIT NONE
+ INTEGER, PARAMETER :: SP = kind(1.0)
+ INTEGER, PARAMETER :: DP = kind(1.0d0)
+ INTEGER, PARAMETER :: WP = DP
+ REAL(WP), PRIVATE :: sample_real_at_WP
+ REAL(WP), PARAMETER :: MAX_REAL_WP = HUGE(sample_real_at_WP)
+ INTEGER, PRIVATE :: sample_int
+ INTEGER, PARAMETER :: MAX_INTEGER = HUGE(sample_int)
+ !> the MPI type for REAL exchanges in simple or double precision
+ INTEGER, PUBLIC :: MPI_REAL_WP
+ !> the MPI type for COMPLEX exchanges in simple or double precision
+ INTEGER, PUBLIC :: MPI_COMPLEX_WP
+
+END MODULE precision
diff --git a/CodesEnVrac/LEGI/test/CMakeLists.txt b/CodesEnVrac/LEGI/test/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..febd4f0ab6f826fc669a9047b2c86fd7dc8c351d
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/CMakeLists.txt
@@ -0,0 +1 @@
+add_subdirectory(src)
diff --git a/CodesEnVrac/LEGI/test/src/CMakeLists.txt b/CodesEnVrac/LEGI/test/src/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..77d584d851d3d4de4a775c806d2ce7875470df05
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/CMakeLists.txt
@@ -0,0 +1,30 @@
+set(EXECUTABLE_OUTPUT_PATH "${TEST_EXE_DIR}")
+include_directories(${CMAKE_Fortran_MODULE_DIRECTORY})
+
+# ===== Test the parallel topology and how it interact with the "global" datalayout (used in the spectral code) =====
+set(TEST_NAME Test_topo)
+ file(GLOB ${TEST_NAME}_FILES ${TEST_NAME}/*.f90)
+ if(${TEST_NAME}_FILES)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_FILES})
+ endif()
+ list(APPEND ${TEST_NAME}_SRC "test_common.f90")
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_topology.f90")
+add_executable(${TEST_NAME} ${${TEST_NAME}_SRC})
+target_link_libraries(${TEST_NAME} ${LIBS})
+
+# ===== Test the advection and the particular solver =====
+set(TEST_NAME Test_advec)
+ # Test file
+ file(GLOB ${TEST_NAME}_FILES ${TEST_NAME}/*.f90)
+ if(${TEST_NAME}_FILES)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_FILES})
+ endif()
+ list(APPEND ${TEST_NAME}_SRC "test_common.f90")
+ # Tested solver
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_topology.f90")
+ file(GLOB ${TEST_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/particle/*.f90)
+ if(${TEST_NAME}_LIB)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_LIB})
+ endif()
+add_executable(${TEST_NAME} ${${TEST_NAME}_SRC})
+target_link_libraries(${TEST_NAME} ${LIBS})
diff --git a/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux.f90 b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..32393d6c36193c49918098c5b0a9c6f092d89ac8
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux.f90
@@ -0,0 +1,368 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection
+!
+! DESCRIPTION:
+!> Validation test for advection method.
+!!
+!! @details
+!! This module provide different test to validate the transport solver.
+!! All these test are unit test : they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular solver
+!! The following test are included :
+!! A - Validate the particular method, step by step
+!! 1 -> Test the procedure "AC_obtain_senders" from advec_common
+!! 2 -> Validate the redistribution the buffer during the remeshing (XXX todo)
+!! 3 -> Validate the remeshing of untagged particles
+!! 4 -> Validate the remeshing of tagged particles (XXX todo)
+!! B - Validate an advection solver (XXX todo)
+!! 1 -> advec a ball with a constant velocity
+!! 2 -> advec a ball with a spheric velocity field (the ball turns)
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module advec_aux
+
+ use string
+ use precision
+ implicit none
+
+ real(WP), private :: epsilon_error = 1e-4 ! Error tolerance
+
+
+ ! Public procedures
+
+ ! ===== Test for the particles solver =====
+ ! Public function
+ public :: test_part_remesh_no_tag
+ public :: test_part_init
+ public :: test_part_advecO2
+ public :: test_advecY
+
+
+ ! ===== Generic test for an advection solver =====
+
+ ! Private procedure
+
+contains
+
+!> Particle method: validation of particle creation
+!! @param[in] direction = to select direction to test
+!! @param[in] init_scal = optional parameter to select initialisation
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_init (direction, init_scal) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use advec_common
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(str_short), intent(in), optional :: init_scal
+ integer, intent(in) :: direction ! current direction
+
+ character(str_short) :: initialisation ! to choose how to initialise the scalar field
+ real(WP), dimension(:, :, :), allocatable :: scalar ! the scalar field
+ real(WP), dimension(:), allocatable :: p_pos, p_V ! the particles position and the scalar they advect
+ real(WP) :: velocity ! constant velocity of the flux
+
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'constant'
+ end if
+ success = .true.
+ call test_substatus('test of particle initialisation !', success, myrank)
+
+end function test_part_init
+
+
+
+
+
+!> Particles method: validation of the remeshing of untagged particles
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_remesh_no_tag (init_scal) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use advec_common
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+
+ character(len=17) :: initialisation ! to choose how to initialise the scalar field
+ character(len=str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scalar ! the scalar field
+ real(WP), dimension(:), allocatable :: p_pos_adim, p_SC ! the adimensionned particles position and the scalar they advect
+ integer, dimension(:), allocatable :: bl_type, bl_tag ! type and tag of each particle bloc
+ real(WP) :: velocity ! constant velocity of the flux
+ integer :: nb_proc ! number of processes
+ integer :: ierr ! mpi error code
+ integer :: i,j,k ! mesh indice
+ integer, dimension(2) :: ind_group ! indice of the current group of line
+ integer :: T_step ! time
+ integer :: T_end ! final time
+ real(WP), dimension(:,:,:), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(3) :: translat ! to compute analytic solution
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+ allocate(scalar(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(p_pos_adim(N_proc(2)))
+ allocate(p_SC(N_proc(2)))
+ allocate(bl_type(1+N_proc(2)/bl_size))
+ allocate(bl_tag((N_proc(2)/bl_size)))
+
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'constant'
+ end if
+ success = .true.
+
+ !call cart_create((/ 1, nb_proc, 1 /), ierr)
+ !call mesh_default()
+
+ ! Choose a velocity
+ velocity = N(2)/11*d_sc(2)
+ T_step = 1
+ T_end = 1
+ T_end = T_step
+ translat = 0
+ translat(2) = - velocity*T_step
+ translat = translat/d_sc
+
+ ! Initialise the scalar field
+ call scal_init(initialisation, scalar, good_scal, translat)
+ call test_substatus('initialisation', success, myrank)
+
+ ! Choose to test remeshing for centered/left and tagged/untagged particles
+ bl_type = 1
+ bl_tag = 0
+
+ ! Advec it with a particular method
+ do k = begin_proc(3), end_proc(3)
+ ind_group(2) = 0
+ !k = begin_proc(3)
+ ind_group(1) = 0
+ ind_group(2) = ind_group(2) + 1
+ do i = begin_proc(1), end_proc(1)
+ !i = begin_proc(1)
+ ind_group(1) = ind_group(1) + 1
+ ! Initialise the particles
+ p_SC = scalar(i,:,k)
+ !scalar(i,:,k)=0
+ do j = begin_proc(2), end_proc(2)
+ p_pos_adim(j) = j
+ end do
+! do T_step = 1, 11
+ ! Advection
+ p_pos_adim = p_pos_adim + T_step*velocity/d_sc(2)
+ ! Remeshing
+ call Yremesh_O2(ind_group, p_pos_adim, bl_type, bl_tag, i, k, scalar)
+! end do
+ end do
+ end do
+
+ ! Check the final scalar field
+ call test_check_success(scalar, good_scal, success)
+
+ deallocate(scalar)
+ deallocate(p_pos_adim)
+ deallocate(p_SC)
+ deallocate(bl_type)
+ deallocate(bl_tag)
+
+ success = .not.success
+
+end function test_part_remesh_no_tag
+
+
+!> Particles method: validation of the advection along one direction with the
+!! order 2 particle method.
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @return error = test error (= false if the code pass the test) (= not success)
+!! @detail
+!! These tests are devoted to validate the advection solver based on particle
+!! method. They can be used for other advection solvers too. Their specificity
+!! is to test each configuration that could be encoutered in the order 2 solver
+!! based on particle method. Therefore they provide complete test for this
+!! order 2 solver but non necessary for a solver based on another method.
+function test_part_advecO2(init_scal, shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+ integer, intent(in), optional :: shift
+
+ character(str_short) :: initialisation ! to choose how to initialise the fields
+ integer :: shift_bis ! shift effectly used in the test
+ character(str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: velo ! the flow
+ integer :: i,j,k ! mesh indice
+ integer :: T_step ! time
+ integer :: T_end ! final time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ integer :: direction = 2 ! current direction
+
+ ! -- Allocation --
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(velo(N_proc(1), N_proc(2), N_proc(3)))
+
+ ! -- Initialisation --
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'center'
+ end if
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ success = .true.
+ dt = 0.1
+
+ call test_substatus('shift', shift_bis, myrank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+ ! Initialise the velocity, the scalar field and compute the theoritical solution
+ call scal_velo_init_part(init_scal, dt, shift_bis, scal3D, velo, direction, good_scal)
+ call test_substatus('initialisation', success, myrank)
+
+ ! Advec it with a particular method
+ call advecY_calc(dt, velo, scal3D, 'p_O2')
+ call test_check_success(scal3D, good_scal, success)
+ call test_substatus('advection', success, myrank)
+
+
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(velo)
+
+ success = .not.success
+
+end function test_part_advecO2
+
+
+!> Test devoted to validate advection solver along one direction
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_advecY(init_scal) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+
+ character(len=17) :: initialisation ! to choose how to initialise the scalar field
+ character(len=str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: Vy ! the flow
+ real(WP) :: velocity ! constant velocity of the flux
+ integer :: ierr ! mpi error code
+ integer :: i,j,k ! mesh indice
+ integer :: T_step ! time
+ integer :: T_end ! final time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(3) :: translat ! to compute analytic solution
+
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'constant'
+ end if
+ success = .true.
+
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+
+ ! Initialise the velocity
+ velocity = N(2)/11*d_sc(2)
+ Vy = velocity
+ T_end = 1
+ translat = 0
+ translat(2) = - velocity*T_end
+ translat = translat/d_sc
+
+ ! Initialise the scalar field
+ call scal_init(initialisation, scal3D, good_scal, translat)
+ call test_substatus('initialisation', success, myrank)
+
+ ! Advec it with a particular method
+ dt = 1
+ call advecY_calc(dt, Vy, scal3D, 'p_O2')
+ call test_check_success(scal3D, good_scal, success)
+ call test_substatus('advec along Y', success, myrank)
+
+
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(Vy)
+
+ success = .not.success
+
+end function test_advecY
+
+
+end module advec_aux
diff --git a/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_common.f90 b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_common.f90
new file mode 100644
index 0000000000000000000000000000000000000000..298f8457544ede39ea168ff58625241f1eb3ef9b
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_common.f90
@@ -0,0 +1,905 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: test_part_common
+!
+! DESCRIPTION:
+!> This module provides tests to validate the particular solver. It is
+!! more precisly focused on testing the "common part" (advec_common) used for each
+!! directions.
+!!
+!! @details
+!! This module is devoted to validate all the procedure from "advec_common". All the
+!! tests are unit tests: they return a logical value to check if the code version pass
+!! it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular
+!! solver
+!! The following test are included :
+!! A - Validate the particular method, step by step
+!! 1 -> Test the procedure "AC_obtain_senders" from advec_common
+!! 2a -> Validate the redistribution the buffer during the remeshing
+!! 2b -> Validate the redistribution the buffer during the remeshing -
+!! debug version : only one processus contains non-zero field.
+!! 3 -> Validate the remeshing of untagged particles
+!! 4 -> Validate the remeshing of tagged particles (XXX todo)
+!! B - Validate an advection solver (in advec_aux)
+!! 1 -> advec a ball with a constant velocity
+!! 2 -> advec a ball with a spheric velocity field (the ball turns)
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module advec_aux_common
+
+ use string
+ use precision
+ implicit none
+
+
+
+ ! ===== Test for the particles solver =====
+ ! Public function
+ public :: test_part_AC_obtain_senders
+ public :: test_part_AC_bufferToScalar
+ public :: test_part_AC_bufferToScalar_Deb
+ public :: test_part_AC_interpol_velocity
+
+
+
+
+contains
+
+
+!> Particles method: validation of the procedure "AC_obtain_senders" wich determine
+!! who will comunicate with who during the remeshing
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] shift = global translation of indices (optional)
+function test_part_AC_obtain_senders(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scale code
+ use advec
+ use advec_common
+ use cart_topology
+ ! Test procdure
+ use test_common
+
+ integer, intent(in), optional :: shift
+ logical :: success
+ ! Be aware : during this function, success = true if everything is right, but we return not success = error
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+ integer :: nb_proc ! number of processes
+ integer :: ierr ! mpi success code
+ integer :: j_min, j_max ! input argument of the tested procedure
+ integer :: proc_min,proc_max! input argument of the tested procedure
+ integer :: send_begin ! theoritical value of proc_min
+ integer :: send_end ! theoritical value of proc_max
+ integer, dimension(2) :: rece_proc ! output argument of the tested procedure
+ integer :: rece_begin ! theoritical value of rece_proc(1)
+ integer :: rece_end ! theoritical value of rece_proc(2)
+ integer, dimension(2) :: ind_group ! indice of current group of lines
+ integer :: direction ! current direction (alonG X, Y or Z)
+
+ ! Some initialisation
+ success = .true.
+ ind_group = 1
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, myrank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+ call test_substatus('initialisation solveur', success, myrank)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ do direction = 1, 3
+ call test_substatus('direction', direction, myrank)
+ ! Test the procedure "AC_obtain_senders"
+ ! If I communicate just with my self
+ bl_bound_size = 0
+ j_min = 1 + shift_bis*N_proc(direction)
+ j_max = N_proc(direction)*(shift_bis+1)
+ proc_min = -1
+ proc_max = -1
+ call AC_obtain_senders(j_min, j_max, direction, D_comm(direction), ind_group, proc_min, proc_max, rece_proc)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ if (rece_proc(1)/=-shift_bis) then
+ call test_substatus(' XXX error - just me', myrank)
+ call test_substatus('rece_proc(1)', rece_proc(1), myrank)
+ call test_substatus('and it must be', -shift_bis, myrank)
+ success = .false.
+ end if
+ if (rece_proc(2)/=-shift_bis) then
+ call test_substatus(' XXX error - just me', myrank)
+ call test_substatus('rece_proc(2)', rece_proc(2), myrank)
+ call test_substatus('and it must be', -shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_min/=shift_bis) then
+ call test_substatus(' XXX error - just me', myrank)
+ call test_substatus('send_proc_min', proc_min, myrank)
+ call test_substatus('and it must be', shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_max/=shift_bis) then
+ call test_substatus(' XXX error - just me', myrank)
+ call test_substatus('send_proc_max', proc_min, myrank)
+ call test_substatus('and it must be', shift_bis, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('just me', success, myrank)
+
+ ! I communicate with my two neighbors
+ call advec_init(order)
+ j_min = shift_bis*N_proc(direction)
+ j_max = (1+shift_bis)*N_proc(direction) -1+2*bl_bound_size
+ proc_min = 0
+ proc_max = 0
+ call AC_obtain_senders(j_min, j_max, direction, D_comm(direction), ind_group, proc_min, proc_max, rece_proc)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ if (rece_proc(1)/=-1-shift_bis) then
+ call test_substatus(' XXX error - neighbors', myrank)
+ call test_substatus('rece_proc(1)', rece_proc(1), myrank)
+ call test_substatus('and it must be', -1-shift_bis, myrank)
+ success = .false.
+ end if
+ if (rece_proc(2)/=1-shift_bis) then
+ call test_substatus(' XXX error - neighbors', myrank)
+ call test_substatus('rece_proc(2)', rece_proc(2), myrank)
+ call test_substatus('and it must be', 1-shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_min/=-1+shift_bis) then
+ call test_substatus(' XXX error - neighbors', myrank)
+ call test_substatus('send_proc_min', proc_min, myrank)
+ call test_substatus('and it must be', -1+shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_max/=1+shift_bis) then
+ call test_substatus(' XXX error - neighbors', myrank)
+ call test_substatus('send_proc_max', proc_min, myrank)
+ call test_substatus('and it must be', 1+shift_bis, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('me and my neighbors', success, myrank)
+
+ ! Contraction / extention
+ if (modulo(nb_proc_dim(direction),2)==0) then
+ if (modulo(myrank,2)== 0) then
+ ! Contraction
+ j_min = 1 + shift_bis*N_proc(2)
+ j_max = (1+shift_bis)*N_proc(2)
+ send_begin = 0
+ send_end = 0
+ else
+ ! Dilatation
+ j_min = +1 - 2*bl_bound_size + shift_bis*N_proc(direction)
+ j_max = (1+shift_bis)*N_proc(direction) + 2*bl_bound_size
+ send_begin = -1
+ send_end = 1
+ end if
+ if (modulo(myrank+shift_bis,2)== 0) then
+ rece_begin = -1
+ rece_end = +1
+ else
+ rece_begin = 0
+ rece_end = 0
+ end if
+ proc_min = send_begin + 1
+ proc_max = send_end + 1
+ call AC_obtain_senders(j_min, j_max, direction, D_comm(direction), ind_group, proc_min, proc_max, rece_proc)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ if (rece_proc(1)/=rece_begin-shift_bis) then
+ call test_substatus(' XXX error contract/dilat', myrank)
+ call test_substatus('rece_proc(1)', rece_proc(1), myrank)
+ call test_substatus('and it must be', rece_begin-shift_bis, myrank)
+ success = .false.
+ end if
+ if (rece_proc(2)/=rece_end-shift_bis) then
+ call test_substatus(' XXX error contract/dilat', myrank)
+ call test_substatus('rece_proc(2)', rece_proc(2), myrank)
+ call test_substatus('and it must be', rece_end-shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_min/=send_begin+shift_bis) then
+ call test_substatus(' XXX error contract/dilat', myrank)
+ call test_substatus('send_proc_min', proc_min, myrank)
+ call test_substatus('and it must be', send_begin+shift_bis, myrank)
+ success = .false.
+ end if
+ if (proc_max/=send_end+shift_bis) then
+ call test_substatus(' XXX error contract/dilat', myrank)
+ call test_substatus('send_proc_max', proc_min, myrank)
+ call test_substatus('and it must be', send_end+shift_bis, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('contraction/extension', success, myrank)
+ else
+ call test_substatus('nb of processus is even', myrank)
+ call test_substatus('no contraction/dilatation test', myrank)
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+
+ success = .not.success
+
+end function test_part_AC_obtain_senders
+
+
+
+!> Particles method: validation of the procedure "AC_bufferToScalar".
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] shift = global translation of indices (optional)
+!! @details
+!! Test the procedure "AC_obtain_senders" wich send local buffer use for remeshing
+!! to the right processes. This procedure belong to "advec_common".
+function test_part_AC_bufferToScalar(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scale code
+ use advec
+ use advec_common
+ use cart_topology
+ ! Test procdure
+ use test_common
+
+ integer, intent(in), optional :: shift
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+ integer :: nb_proc ! number of processes
+ integer :: ierr ! mpi success code
+ integer :: j_min, j_max ! input argument of the tested procedure
+ real(WP), dimension(:), allocatable :: send_buffer ! the buffer to redistribute
+ real(WP), dimension(:), allocatable :: scal1D ! the scalar field
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ integer :: success_inf ! norm L_inf of the success
+ real(WP) :: good_scal ! theoritical value of scal1D
+ integer, dimension(2) :: mycoord ! my coordonate in the mpi topology
+ integer, dimension(2) :: ind_group ! indice of current group of lines
+
+ ! Some initialisation
+ success = .true.
+ ind_group = 1
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, myrank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+ do direction = 1, 3
+ call test_substatus('direction', direction, myrank)
+ good_scal = modulo(coord(direction)-shift_bis, nb_proc_dim(direction))
+
+ ! Test 1 - unrealistic case with no communication
+ ! Initialize the buffer to remesh
+ bl_bound_size = 0
+ j_min = 1 + shift_bis*N_proc(direction)
+ j_max = N_proc(direction)*(shift_bis+1)
+ allocate (send_buffer(j_min:j_max))
+ allocate (scal1D(1:N_proc(direction)))
+ send_buffer = coord(direction)
+ scal1D = 0.0
+ ! Let's go !
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call AC_bufferToScalar(direction, D_comm(direction), ind_group, j_min, j_max, send_buffer, scal1D)
+ ! Check the success
+ call test_check_success_S(scal1D, good_scal, success)
+ deallocate (send_buffer)
+ deallocate (scal1D)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('just me', success, myrank)
+
+ ! I communicate with my two neighbors
+ call advec_init(order)
+ j_min = shift_bis*N_proc(direction)
+ j_max = (1+shift_bis)*N_proc(direction) -1+2*bl_bound_size
+ allocate (send_buffer(j_min:j_max))
+ allocate (scal1D(1:N_proc(direction)))
+ send_buffer = coord(direction)
+ send_buffer(j_min) = modulo(coord(direction)-1, nb_proc_dim(direction))/2.0
+ send_buffer(j_min+1) = send_buffer(j_min+1)/2.
+ send_buffer(j_max) = modulo(coord(direction)+1, nb_proc_dim(direction))/2.0
+ send_buffer(j_max-1) = send_buffer(j_max-1)/2.
+ scal1D = 0.0
+ call AC_bufferToScalar(direction, D_comm(direction), ind_group, j_min, j_max, send_buffer, scal1D)
+ ! Check the success
+ call test_check_success_S(scal1D, good_scal, success)
+ deallocate (send_buffer)
+ deallocate (scal1D)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('me and my neighbors', success, myrank)
+ end do
+
+ success = .not.success
+
+end function test_part_AC_bufferToScalar
+
+
+
+!> Particles method: validation of the procedure "AC_bufferToScalar"
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] shift = global translation of indices (optional)
+!! @param[in] rank = rank of the processus which will contains non-zero field.
+!! @details
+!! Debugging version : only one processus contains non zero field to remesh.
+!! Each processus communicate with its two neibor. A shift could be add.
+function test_part_AC_bufferToScalar_Deb(rank, shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scale code
+ use advec
+ use advec_common
+ use cart_topology
+ ! Test procdure
+ use test_common
+
+ integer, intent(in) :: rank
+ integer, intent(in), optional :: shift
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+ integer :: nb_proc ! number of processes
+ integer :: ierr ! mpi success code
+ integer :: j_min, j_max ! input argument of the tested procedure
+ real(WP), dimension(:), allocatable :: send_buffer ! the buffer to redistribute
+ real(WP), dimension(:), allocatable :: scal1D ! the scalar field
+ real(WP), dimension(:), allocatable :: good_scal ! theoritical value of scal1D
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ integer, dimension(3) :: mycoord ! my coordonates in the mpi topology
+ integer :: rank_shift ! rank of processus of rank = rank+shift
+ integer, dimension(2) :: ind_group ! indice of current group of lines
+
+ ! Some initialisation
+ success = .true.
+ ind_group = 1
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, myrank)
+ call test_substatus('rank tested', rank, myrank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+ do direction = 1, 3
+ call test_substatus('direction', direction, myrank)
+ ! Initialise the solver environnement and the field
+ call advec_init(order)
+ j_min = shift_bis*N_proc(direction)
+ j_max = (1+shift_bis)*N_proc(direction) -1+2*bl_bound_size
+ allocate (send_buffer(j_min:j_max))
+ allocate (scal1D(1:N_proc(direction)))
+ send_buffer = 0
+ if (myrank == rank) then
+ send_buffer = 2
+ send_buffer(j_min) = 1
+ send_buffer(j_max) = 3
+ end if
+ scal1D = 0.0
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! Compute the analytic solution
+ allocate (good_scal(1:N_proc(direction)))
+ good_scal = 0.0
+ ! For the processus wich correcpond to me after the shift
+ call mpi_cart_coords(cart_comm, rank, 3, mycoord, ierr)
+ mycoord(direction) = mycoord(direction) + shift_bis
+ call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+ if (myrank==rank_shift) good_scal = 2
+ ! For the next processus in the current direction
+ mycoord(direction) = mycoord(direction) + 1
+ call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+ if (myrank==rank_shift) good_scal(1) = 3
+ ! For the previous processus in the current direction
+ mycoord(direction) = mycoord(direction) -2
+ call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+ if (myrank==rank_shift) good_scal(N_proc(direction)) = 1
+
+ ! Compute the numerical solution
+ call AC_bufferToScalar(direction, D_comm(direction), ind_group, j_min, j_max, send_buffer, scal1D)
+ ! Check the success
+ call test_check_success_F(scal1D, good_scal, success)
+ deallocate (send_buffer)
+ deallocate (scal1D)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('me and my neighbors', success, myrank)
+ end do
+
+ success = .not.success
+
+
+end function test_part_AC_bufferToScalar_Deb
+
+
+!> Particles method: validation of the procedure "AC_obtain_senders" wich determine
+!! who will comunicate with who during the remeshing
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] shift = global translation of indices (optional)
+function test_part_AC_obtain_recevers(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scale code
+ use advec_common
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ integer, intent(in), optional :: shift
+ logical :: success
+ ! Be aware : during this function, success = true if everything is right, but we return not success = error
+
+ integer :: shift_bis ! global translation of indices
+ integer :: direction ! current direction
+ integer :: comm ! associated mpi communicator
+ integer :: rece_ind_min ! the minimal indice used in velocity interpolation
+ integer :: rece_ind_max ! the maximal indice used in velocity interpolation
+ integer, dimension(2) :: rece_gap ! distance between me and processus wich send me information
+ integer, dimension(2) :: send_gap ! distance between me and processus to wich I send information
+ integer :: nn, clock ! to generate random number
+ integer, dimension(:), allocatable :: seed ! to generate random number
+ real(WP) :: p_pos_1,p_pos_end! location where the velocity is interpolated
+ integer :: ind, indbis ! indices
+ real(WP), dimension(2) :: r ! random numbers to initialise p_pos
+ integer :: ierr ! mpi error code
+ integer :: i, k, ite ! indices
+
+ call test_substatus('test AC_obtain_recevers', myrank)
+
+ ! Some initialisation
+ success = .true.
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, myrank)
+ direction = 2
+ comm = Y_comm
+ ! Init the particles data
+ ! To generate random number
+ call RANDOM_SEED(size = nn)
+ allocate(seed(nn))
+ call SYSTEM_CLOCK(COUNT=clock)
+ seed = clock + 37 * (/ (ind - 1, ind = 1, nn) /)
+ call RANDOM_SEED(PUT = seed)
+ deallocate(seed)
+ ! Position where the velocity will be interpolated
+ CALL RANDOM_NUMBER(r)
+ p_pos_1 = (1+shift_bis+r(1))*d_sc(direction)
+ p_pos_end = (N_proc(direction)+shift_bis+r(2))*d_sc(direction)
+
+ ! Compute range of the set of point where I need the velocity value
+ rece_ind_min = floor(p_pos_1/d_sc(direction))
+ rece_ind_max = floor(p_pos_end/d_sc(direction)) + 1
+ ! Test the function
+ indbis=0
+ do ite = 1, 10
+ do i = 1, 100
+ do k = 1, 100
+ ind = ind + 1
+ call AC_obtain_receivers(direction, comm, (/i, k/), rece_ind_min, rece_ind_max, send_gap, rece_gap)
+ if (ind>indbis*100000) then
+ call test_substatus('iteration/100000', ind/100000, myrank)
+ indbis = indbis+1
+ end if
+ end do
+ end do
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+
+ success = .not. success
+
+end function test_part_AC_obtain_recevers
+
+
+!> Particles method: validation of the velocity interpolation
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] direction = 1 for along X, 2 for along Y, 3 for along Z
+!! @param[in] comm = mpi communcator associated to direction
+!! @param[in] shift = global translation of indice
+function test_part_AC_interpol_velocity(direction, comm, shift) result(success)
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ integer, intent(in) :: direction, comm, shift
+
+ integer :: ind ! indice
+ integer :: nn, clock ! to generate random number
+ integer, dimension(:), allocatable :: seed ! to generate random number
+ real(WP), dimension(N_proc(direction)) :: p_pos ! location where the velocity is interpolated
+ real(WP), dimension(N_proc(direction)) :: r ! random numbers to initialise p_pos
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)) :: velo ! velocity field
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)) :: good_velo ! analytic interpolation of velocity field in particles position
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)) :: num_velo ! numerical interpolation of velocity field in particles position
+ real(WP) :: dt ! time step
+ integer :: T ! for solver iteration
+ integer :: ierr ! mpi error code
+
+
+ call test_substatus('test velocity interpolation', myrank)
+ call test_substatus('shift', shift, myrank)
+
+ ! Initialisation
+ success = .true.
+ ! To generate random number
+ call RANDOM_SEED(size = nn)
+ allocate(seed(nn))
+ call SYSTEM_CLOCK(COUNT=clock)
+ seed = clock + 37 * (/ (ind - 1, ind = 1, nn) /)
+ call RANDOM_SEED(PUT = seed)
+ deallocate(seed)
+ ! Position where the velocity will be interpolated
+ CALL RANDOM_NUMBER(r)
+ do ind = 1, N_proc(direction)
+ p_pos(ind) = (ind+shift)
+ end do
+
+ ! ===== Particles are on mesh point =====
+ call test_substatus('particles are placed on a mesh point', myrank)
+ ! - Basic test : constant velocity -
+ call velo_init('constant', velo, direction, p_pos, good_velo)
+ dt = 0.0
+do T = 1, 10
+ call aux_com_interpol(dt, direction, comm, p_pos, velo, num_velo)
+ ! Check result
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_check_success(num_velo, good_velo, success)
+end do
+ call test_substatus('constant velocity', success, myrank)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ ! - Normal test -
+ call velo_init('translation_field', velo, direction, p_pos, good_velo)
+ call aux_com_interpol(dt, direction, comm, p_pos, velo, num_velo)
+ ! Check result
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_check_success(num_velo, good_velo, success)
+ call test_substatus('translation_field', success, myrank)
+
+
+ ! ===== Test with p_pos not on a mesh point =====
+ call test_substatus('particles are not placed on a mesh point', myrank)
+ p_pos = p_pos + r*d_sc(direction)
+ ! - Basic test : constant velocity -
+ call velo_init('constant', velo, direction, p_pos, good_velo)
+ do T = 1, 10
+ call aux_com_interpol(dt, direction, comm, p_pos, velo, num_velo)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ end do
+ ! Check result
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_check_success(num_velo, good_velo, success)
+ call test_substatus('constant velocity', success, myrank)
+ ! - Normal test -
+ call velo_init('translation_field', velo, direction, p_pos, good_velo)
+ call aux_com_interpol(dt, direction, comm, p_pos, velo, num_velo)
+ ! Check result
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_check_success(num_velo, good_velo, success)
+ call test_substatus('translation_field', success, myrank)
+
+
+ ! Return not success
+ success = .not. success
+
+end function test_part_AC_interpol_velocity
+
+
+!> Particle method: validation of particle tag and block type determination
+!! @return error = test error (= false if the code pass the test) (= not success)
+!! @param[in] shift = global translation of indices (optional)
+function test_part_AC_type_and_block_O2(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advec_common
+ use cart_topology
+ ! Test procedures
+ use test_common
+
+ integer, intent(in), optional :: shift
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+
+ integer, dimension(:), allocatable :: bl_type ! correct (analytic) type of block
+ integer, dimension(:), allocatable :: bl_tag ! correct (analytic) tag of block
+ integer, dimension(:), allocatable :: good_type ! correct (analytic) type of block
+ integer, dimension(:), allocatable :: good_tag ! correct (analytic) tag of block
+ integer :: ierr ! mpi success code
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ integer, dimension(2) :: ind_group ! indice of the current group of line
+ real(WP) :: dt, cfl ! time step and CFL number
+ real(WP), dimension(:), allocatable :: p_V ! particle velocity (used to tag particles)
+ real(WP) :: p_V_next ! velocity of the first particle of the next block
+ ! (used to determine block type and to tag particles)
+ integer, dimension(3) :: comm_table ! table of mpi communicator dedicaced to each direction
+ integer :: ind, ind2 ! indice of the current particle
+ integer :: ind_bl ! indice of the current block
+ real(WP) :: lambda_min ! minimum courant number on a block
+ integer :: ind_tag_bl ! indice of the first tagged block in the test
+ integer :: ind_tag_p ! indice of particle corresponding to the velocity
+ ! variation wich induce a tag of the block ind_tag_bl
+ integer :: ind_tag_bl2 ! indice of the second tagged block in the test
+ integer :: ind_tag_p2 ! indice of particle wich induce a tag of the block ind_tag_bl2
+
+
+ ! Some initialisation
+ success = .true.
+ ind_group = 1
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, myrank)
+ call advec_init('p_O2')
+ dt = 0.01
+ comm_table(1) = X_comm
+ comm_table(2) = Y_comm
+ comm_table(3) = Z_comm
+
+direction = 2
+! do direction = 1, 3
+ call test_substatus('direction', direction, myrank)
+ allocate(good_type(bl_number(direction)+1))
+ allocate(good_tag(bl_number(direction)))
+ allocate(bl_type(bl_number(direction)+1))
+ allocate(bl_tag(bl_number(direction)))
+ allocate(p_V(N_proc(direction)))
+ cfl = dt/d_sc(direction)
+ if (cfl == 0) cfl = 1
+
+ ! -- Test case 1 : only left block, no tag --
+ p_V = 0.4/cfl
+ good_tag = 0
+ good_type = 0
+ call AC_type_and_block(dt, direction, comm_table(direction), (/1,1/), p_V, &
+ & bl_type, bl_tag)
+ call test_check_success(bl_tag, good_tag, success)
+ call test_substatus('test 1.a - no tag ', success, myrank)
+ call test_check_success(bl_type, good_type, success)
+ call test_substatus('test 1.a - left particle only', success, myrank)
+ call MPI_barrier(MPI_COMM_WORLD, ierr)
+ ! And for another velocity
+ p_V = -2.8/cfl
+ call AC_type_and_block(dt, direction, comm_table(direction), (/1,1/), p_V, &
+ & bl_type, bl_tag)
+ call test_check_success(bl_tag, good_tag, success)
+ call test_substatus('test 1.b - no tag ', success, myrank)
+ call test_check_success(bl_type, good_type, success)
+ call test_substatus('test 1.b - left block only', success, myrank)
+
+ ! Test case 2 : only center block, no tag
+ p_V = -0.4/cfl
+ good_tag = 0
+ good_type = 1
+ call AC_type_and_block(dt, direction, comm_table(direction), (/1,1/), p_V, &
+ & bl_type, bl_tag)
+ call test_check_success(bl_tag, good_tag, success)
+ call test_substatus('test 2.a - no tag ', success, myrank)
+ call test_check_success(bl_type, good_type, success)
+ call test_substatus('test 2.a - center particle only', success, myrank)
+ call MPI_barrier(MPI_COMM_WORLD, ierr)
+ ! And for another velocity
+ p_V = 6.8/cfl
+ call AC_type_and_block(dt, direction, comm_table(direction), (/1,1/), p_V, &
+ & bl_type, bl_tag)
+ call test_check_success(bl_tag, good_tag, success)
+ call test_substatus('test 2.b - no tag ', success, myrank)
+ call test_check_success(bl_type, good_type, success)
+ call test_substatus('test 2.b - center particle only', success, myrank)
+
+ ! Test case 3 = 2 tag
+ ! one for an extension: on the left part of the domain all block are left
+ ! one, on the right side they are center and there is a gap of 1 in the block index
+ ! one for a contraction: on the left part of the domain all block are center
+ ! one, on the right side they are left and there is a gap of -1 in the block index
+ ! => particles are tagged on the location of the switch
+ ! Update dt in order to create "chock" without broke the stability condition
+ dt = 0.8*d_sc(direction)/sqrt(2*1.2*bl_size)
+ cfl = dt/d_sc(direction)
+ good_type = 0
+ good_tag = 0
+ p_V = shift_bis/cfl
+ ind_tag_bl = (nb_proc_dim(direction)*bl_number(direction)/3) - (bl_number(direction)*coord(direction))
+ ind_tag_p = (ind_tag_bl-1)*bl_size + bl_size/2 + 1
+ ind_tag_p2 = floor((0.3/0.8)*(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p) + ind_tag_p)
+ ind_tag_p2 = ind_tag_p2 + 1
+ ind_tag_bl2 = (ind_tag_p2 - 1 - bl_size/2)/bl_size + 1
+ if (modulo(ind_tag_p2-1-bl_size/2, bl_size)==0) ind_tag_bl2 = ind_tag_bl2 -1
+ if (ind_tag_bl <=bl_number(direction)) then
+ if (ind_tag_bl>=1) then
+ ! Tag the right block transition
+ good_tag(ind_tag_bl) = 1
+ else
+ ! Change the velocity for the first half block
+ lambda_min = max(0,shift_bis) + 10
+ do ind = 1, bl_size/2
+ p_V(ind) = shift_bis/cfl
+ p_V(ind) = p_V(ind) + 0.8*(1.0-float(ind-ind_tag_p)/(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind+1<ind_tag_p2) good_type(1) = 1
+ end if
+ ! Update velocity and block type
+ do ind_bl = max(2, ind_tag_bl+1), bl_number(direction)
+ lambda_min = max(0,shift_bis) + 10
+ do ind = 1, bl_size
+ ind2 = ind+((ind_bl-2)*bl_size)+bl_size/2 ! the first block is only a half block
+ p_V(ind2) = shift_bis/cfl
+ p_V(ind2) = p_V(ind2)+0.8*(1.-float(ind2-ind_tag_p)/(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind2+1<ind_tag_p2) good_type(ind_bl) = 1
+ end do
+ ! For the last half block
+ lambda_min = max(0,shift_bis) + 10
+ ind_bl = bl_number(direction) + 1
+ do ind = 1, bl_size/2
+ ind2 = ind+((ind_bl-2)*bl_size)+bl_size/2 ! the first block is only a half block
+ p_V(ind2) = shift_bis/cfl
+ p_V(ind2) = p_V(ind2)+0.8*(1.-float(ind2-ind_tag_p)/(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind2+bl_size/2+1<ind_tag_p2) good_type(ind_bl) = 1
+ end if
+ if ((ind_tag_bl2 <= bl_number(direction)).and.(ind_tag_bl2>0)) good_tag(ind_tag_bl2) = 1
+ call AC_type_and_block(dt, direction, comm_table(direction), (/1,1/), p_V, &
+ & bl_type, bl_tag)
+
+! == Pour debugger sur 1 processus ==
+!print*, 'ind_tag_p2 = ', ind_tag_p2
+!print*, 'V(ind_tag_p2) = ', p_V(ind_tag_p2)*cfl
+!print*, 'ind_tag_bl2 = ', ind_tag_bl2
+!do ind = 0, 9
+!print*, ' V de ', ind*10+1, ' a ', (ind+1)*10
+!print*, p_V(ind*10+1:(ind+1)*10)*cfl
+!print*, 'tag associé :'
+!print*, bl_tag(ind*5+1:(ind+1)*5)
+!print*, 'tag prevu :'
+!print*, good_tag(ind*5+1:(ind+1)*5)
+!print*, 'type associé :'
+!print*, bl_type(ind*5+1:(ind+1)*5+1)
+!print*, 'type prevu :'
+!print*, good_type(ind*5+1:(ind+1)*5+1)
+!end do
+! == Pour debugger en parallele ==
+if (maxval(abs(bl_type-good_type))>0) then
+print*, 'myrank = ', myrank
+print*, 'p_V = ', p_V*cfl
+print*, 'type associé :'
+print*, bl_type
+print*, 'type prevu :'
+print*, good_type
+end if
+
+ call test_check_success(bl_tag, good_tag, success)
+ call test_substatus('test 3 - one tag ', success, myrank)
+ call test_check_success(bl_type, good_type, success)
+ call test_substatus('test 3 - center at first, then left', success, myrank)
+ call MPI_barrier(MPI_COMM_WORLD, ierr)
+
+
+ deallocate(good_type)
+ deallocate(good_tag)
+ deallocate(bl_type)
+ deallocate(bl_tag)
+ deallocate(p_V)
+! end do
+
+ success = .not. success
+
+end function test_part_AC_type_and_block_O2
+
+
+! ===== Private procedure =====
+
+
+!> Particles method: interpolate the velocity on all the 3D domain
+!! @param[in] dt = time step
+!! @param[in] direction = 1 for along X, 2 for along Y, 3 for along Z
+!! @param[in] comm = mpi communcator associated to direction
+!! @param[in] p_pos = particle position
+!! @param[in] velo = velocity field
+!! @param[out] num_velo = numerical interpolation of the velocity field
+!! @details
+!! The function AC_particle_velocity interpolate the velocity on a 1D line
+!! (along X, Y or Z-axis). In order to test it on all direction and on 3D
+!! cases, this subroutine call this interpolation on each line of the domain.
+subroutine aux_com_interpol(dt, direction, comm, p_pos, velo, num_velo)
+
+ ! Scales code
+ use advec_common
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ real(WP), intent(in) :: dt ! time step
+ integer, intent(in) :: direction, comm
+ real(WP), dimension(N_proc(direction)), intent(in) :: p_pos ! location where the velocity is interpolated
+ real(WP), dimension(:,:,:), intent(in) :: velo ! velocity field
+ real(WP), dimension(N_proc(1), N_proc(2), N_proc(3)), intent(out) :: num_velo ! numerical interpolation of velocity field
+
+ integer :: i,j,k,ind ! indice
+ real(WP), dimension(N_proc(direction)) :: p_V ! particles velocity (interpolation of velo in location p_pos)
+
+ select case(direction)
+ case(1)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do ind = 1, N_proc(1)
+ p_V(ind) = velo(ind, j, k)
+ end do
+ call AC_particle_velocity(dt, direction, comm, (/j, k/), p_pos, p_V)
+ do ind = 1, N_proc(1)
+ num_velo(ind,j,k)= p_V(ind)
+ end do
+ end do
+ end do
+ case(2)
+ do k = 1, N_proc(3)
+ do i = 1, N_proc(1)
+ do ind = 1, N_proc(2)
+ p_V(ind) = velo(i, ind, k)
+ end do
+ call AC_particle_velocity(dt, direction, comm, (/i, k/), p_pos, p_V)
+ do ind = 1, N_proc(2)
+ num_velo(i, ind,k)= p_V(ind)
+ end do
+ end do
+ end do
+ case(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ do ind = 1, N_proc(2)
+ p_V(ind) = velo(i, j, ind)
+ end do
+ call AC_particle_velocity(dt, direction, comm, (/i, k/), p_pos, p_V)
+ do ind = 1, N_proc(2)
+ num_velo(i, j, ind)= p_V(ind)
+ end do
+ end do
+ end do
+ end select
+
+end subroutine aux_com_interpol
+
+end module advec_aux_common
diff --git a/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_init.f90 b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..77362d68f8fa06a58764c1f9c8dde053997f5b7f
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_advec/advec_aux_init.f90
@@ -0,0 +1,417 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection_init
+!
+! DESCRIPTION:
+!> Initialisation procedure for advection test (and solver based on particle method).
+!!
+!! @details
+!! This module provide different initialisation setup in order to test the transport solver.
+!!
+!! The following initialisation are included :
+!! 1 -> Constant field for both scalar and velocity
+!! 2 -> 2D-rotation of a sphere
+!! 3 -> scalar(i,j,k) = i/Nx + 10* j/Ny + 100*k/Nz with periodic boundary condition
+!! 4 -> velocity(i,j,k) = i/Nx + 10* j/Ny + 100*k/Nz with periodic boundary condition
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module advec_aux_init
+
+ use string
+ use precision
+ implicit none
+
+ ! ===== Initialisation for advection test =====
+ ! Public function
+ public :: velo_init
+ public :: scal_init
+ public :: scal_velo_init_part
+ ! Private function
+ private :: compute_velo_tag
+
+ ! ===== Setup parameter =====
+ ! Public variables
+ !> Period for rotation cases
+ real(WP), public :: period = 1
+ ! Private variable
+ !> Pi value
+ real(WP), private :: M_PI = ACOS(0.0)
+
+
+
+
+contains
+
+!> Initialisation of the scalar field for the different tests.
+!! @param[in] init = parameter to initialise the scalar fied to a constant one or to a sphere shape
+!! @param[in] translat = optional argument, translat the field, in order to obtain analytic solution for non zero velocity in test case
+!! "translation field"
+!! @param[out] scalar = scalar field
+!! @param[out] good_scal = analytic solution
+subroutine scal_init(init, scalar, good_scal, translat)
+
+ use test_common
+ use cart_topology
+
+ character(len=*), intent(in) :: init
+ real(WP), dimension(:,:,:), intent(out) :: scalar
+ real(WP), dimension(:,:,:), intent(out) :: good_scal
+ real(WP), dimension(3), intent(in), optional :: translat
+
+ real(WP) :: rr, rx, ry, rz, shift, rayon
+ real(WP) :: dist
+ integer :: i, j, k
+ integer :: ierr ! mpi error code
+
+
+ select case(init)
+ case('constant')
+ call test_substatus('constant scal', myrank)
+ scalar = 1.
+ good_scal = 1.
+ case('turning_sphere')
+ scalar = 0.
+ rayon = (minval(N*d_sc)/10.0)**2
+ do k = 1, N_proc(3)
+ rz = (k + coordYZ(3-1)+1- 3.0*N(3)/5.0)**2
+ do j = 1, N_proc(2)
+ ry = (j + coordYZ(2-1)+1- 3.0*N(2)/5.0)**2
+ do i = 1, N_proc(1)
+ rx = (d_sc(1)*(i - 3.0*N(1)/5.0))**2
+ rr = rx + ry + rz
+ if (rr> rayon) scalar(i,j,k) = 1 - rr/rayon
+ end do
+ end do
+ end do
+ good_scal = scalar
+ case('translation_field')
+! XXX / Todo : la solution n'est pas périodique !! Pomper ce qui a été fait dans
+! velo_init, car là c'est bien périodique.
+! / XXX
+ call test_substatus('translation field', myrank)
+ if (present(translat)) then
+ call test_substatus('translation on X', translat(1), myrank)
+ call test_substatus('translation on Y', translat(2), myrank)
+ call test_substatus('translation on Z', translat(3), myrank)
+ else
+ call test_substatus('velocity = zero ', myrank)
+ end if
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ scalar(i,j,k) = (float(i-1+coord(1)*N_proc(1))/N(1))
+ scalar(i,j,k) = scalar(i,j,k) + 10*(float(j-1+coord(2)*N_proc(2))/N(2))
+ scalar(i,j,k) = scalar(i,j,k) + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (present(translat)) then
+ ! Only periodic condition
+ dist = (i+translat(1)-1+coord(1)*N_proc(1))*d_sc(1) ! distance au bord x = 0
+ dist = modulo(dist, length(1)) ! on utilise la periodicite
+ ! If dist belong to (length - dx, length) then with have to interpolate
+ ! the velocity between postion (length-dx) and 0 (due to periodicity boundary condition)
+ if (dist>length(1)-d_sc(1)) dist = (length(1)-dist)*(length(1)-d_sc(1))/d_sc(1)
+ ! In other case, as the velocity is a linear function of the position, the analytic velocity
+ ! is the same that the interpolate one
+ good_scal(i,j,k) = dist/length(1)
+ dist = (j+translat(2)-1+coord(2)*N_proc(2))*d_sc(2)
+ dist = modulo(dist, length(2))
+ if (dist>length(2)-d_sc(2)) dist = (length(2)-dist)*(length(2)-d_sc(2))/d_sc(2)
+ good_scal(i,j,k) = good_scal(i,j,k) + 10*(dist)/length(2)
+ dist = (k+translat(3)-1+coord(3)*N_proc(3))*d_sc(3)
+ dist = modulo(dist, length(3))
+ ! See direction 1 for explaination
+ if (dist>length(3)-d_sc(3)) dist = (length(3)-dist)*(length(3)-d_sc(3))/d_sc(3)
+ good_scal(i,j,k) = good_scal(i,j,k) + 100*(dist)/length(3)
+ else
+ good_scal(i,j,k) = scalar(i,j,k)
+ end if
+ end do
+ end do
+ end do
+ case default
+ scalar = 1.
+ good_scal = 1.
+ end select
+
+end subroutine scal_init
+
+
+
+!> Initialisation of the velocity field to test its interpolation
+!! @param[in] init = parameter to initialise the scalar fied to a constant one or to a sphere shape
+!! @param[out] velo = velocity field along one direction
+!! @param[in] direction = current direction (along X,Y or Z-axis)
+!! @param[in] p_pos_adim = adimensionned particles postion (location where the velocity will be interpolated)
+!! @param[in,out] good_velo = analytic interpolation of the velocity field (on location p_pos)
+subroutine velo_init(init, velo, direction, p_pos_adim, good_velo)
+
+ use test_common
+ use cart_topology
+
+ character(len=*), intent(in) :: init
+ real(WP), dimension(:,:,:), intent(inout) :: velo
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ integer, intent(in) :: direction
+ real(WP), dimension(:,:,:), intent(inout) :: good_velo
+
+ integer :: i, j, k ! mesh indices
+ integer :: ierr ! mpi error code
+ real(WP) :: dist ! distance from boundary
+
+
+ select case(init)
+ case('constant')
+ velo = 1.
+ good_velo = 1.
+ case('2D_rot')
+ select case(direction)
+ case(1)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=(M_PI/period)*(N(2)/2.0-(j+coord(2)))*d_sc(2);
+ good_velo(i,j,k)=(M_PI/period)*(N(2)/2.0-j-0.5)*d_sc(2);
+ end do
+ end do
+ end do
+ case(2)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=(M_PI/period)*((i+coord(1)) - N(1)/2.0)*d_sc(1);
+ good_velo(i,j,k)=(M_PI/period)*((i+coord(1)) - N(1)/2.0)*d_sc(1);
+ end do
+ end do
+ end do
+ case(3)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=0
+ good_velo(i,j,k)=0
+ end do
+ end do
+ end do
+ case default
+ call test_substatus(' XXX error : wrong direction =', direction, myrank)
+ stop
+ end select
+ case('translation_field')
+ select case(direction)
+ case(1)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(1) .eqv. .true.) then
+ dist = (p_pos_adim(i)-1+coord(1)*N_proc(1))*d_sc(1) ! distance au bord x = 0
+ dist = modulo(dist, length(1)) ! on utilise la periodicite
+ ! If dist belong to (length - dx, length) then with have to interpolate
+ ! the velocity between postion (length-dx) and 0 (due to periodicity boundary condition)
+ if (dist>length(1)-d_sc(1)) dist = (length(1)-dist)*(length(1)-d_sc(1))/d_sc(1)
+ ! In other case, as the velocity is a linear function of the position, the analytic velocity
+ ! is the same that the interpolate one
+ good_velo(i,j,k) = dist/length(1) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ else
+ call test_substatus(' boundary along X condition not implemented ', myrank)
+ end if
+ end do
+ end do
+ end do
+ case(2)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(2) .eqv. .true.) then
+ dist = (p_pos_adim(j)-1+coord(2)*N_proc(2))*d_sc(2)
+ dist = modulo(dist, length(2))
+ ! See direction 1 for explaination
+ if (dist>length(2)-d_sc(2)) dist = (length(2)-dist)*(length(2)-d_sc(2))/d_sc(2)
+ good_velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(dist)/length(2) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ else
+ call test_substatus(' boundary along X condition not implemented ', myrank)
+ end if
+ end do
+ end do
+ end do
+ case(3)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(3) .eqv. .true.) then
+ dist = (p_pos_adim(k)-1+coord(3)*N_proc(3))*d_sc(3)
+ dist = modulo(dist, length(3))
+ ! See direction 1 for explaination
+ if (dist>length(3)-d_sc(3)) dist = (length(3)-dist)*(length(3)-d_sc(3))/d_sc(3)
+ good_velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*dist/length(3)
+ else
+ call test_substatus(' boundary along X condition not implemented ', myrank)
+ end if
+ end do
+ end do
+ end do
+ case default
+ call test_substatus(' XXX error : wrong direction =', direction, myrank)
+ stop
+ end select
+ case default
+ velo = 1.
+ good_velo = 1.
+ end select
+
+
+end subroutine velo_init
+
+!> Initialisation of the velocity field to test its interpolation
+!! @param[in] init = parameter used to choose between the different setup
+!! @param[in,out] dt = time step (used to compute solution)
+!! @param[in] shift = global translation of indices (optional)
+!! @param[out] scalar3D = scalar field
+!! @param[out] velo = velocity field along one direction
+!! @param[in] direction = current direction (along X,Y or Z-axis)
+!! @param[out] good_scal = analytic solution of the advection problem
+subroutine scal_velo_init_part(init, dt, shift, scal3D, velo, direction, good_scal)
+
+ ! Scales code
+ use cart_topology
+ use advec_common
+ ! Test procedures
+ use test_common
+
+ character(len=*), intent(in) :: init
+ real(WP), intent(inout) :: dt
+ integer, intent(in) :: shift
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: velo
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: scal3D
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: good_scal
+ integer, intent(in) :: direction
+
+ integer :: i, j, k ! mesh indices
+ integer :: ierr ! mpi error code
+ real(WP) :: cfl ! ratio between time and space steps
+ real(WP) :: t ! some time indication
+ real(WP) :: dt_bis ! time step used to compute trajectories
+ ! with a numerical integration
+ real(WP) :: sX, sY, sZ ! some temp variable
+ real(WP), dimension(3) :: vect_dir ! some temp variable
+
+
+ cfl = dt/d_sc(direction)
+
+
+ ! -- Initialize velocity and compute some trajectories --
+ select case(init)
+ case('left')
+ ! -- Test case 1 : only left block, no tag --
+ velo = (shift+0.3)/cfl
+ velo = d_sc(direction)/dt
+ scal3D = -dt*velo
+ call test_substatus('particle- no tag, only left block', myrank)
+
+ case('tag')
+ ! Update dt in order to create "chock" without broke the stability condition
+ dt = 0.8*d_sc(direction)/sqrt(2*1.2*bl_size)
+ cfl = dt/d_sc(direction)
+ ! Compute trajectories
+ scal3D = 0.0
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = compute_velo_tag(dble(j), shift, cfl, direction)
+ dt_bis = min(0.01, dt/10)
+ t = 0
+ do while(t <= dt-dt_bis)
+ scal3D(i,j,k) = scal3D(i,j,k) &
+ &- dt_bis*compute_velo_tag(j+scal3D(i,j,k), shift, cfl, direction)/d_sc(direction)
+ t = t + dt_bis
+ end do
+ dt_bis = dt - t
+ scal3D(i,j,k) = scal3D(i,j,k) &
+ &- dt_bis*compute_velo_tag(j+scal3D(i,j,k), shift, cfl, direction)/d_sc(direction)
+ end do
+ end do
+ end do
+ call test_substatus('particle- 2 tag, left and center', myrank)
+
+ case default ! default = 'center'
+ ! Test case 2 : only center block, no tag
+ velo = (shift+0.8)/cfl
+ velo = d_sc(direction)/dt
+ scal3D = -dt*velo
+ call test_substatus('particle- no tag, only center block', myrank)
+ end select
+
+ ! -- Compute solution of the advection problem
+ vect_dir = 0
+ vect_dir(direction) = 1
+ do k = 1, N_proc(3)
+ sZ = (k-1+(coord(3)*N_proc(3)))*d_sc(3)
+ do j = 1, N_proc(2)
+ sY = (j-1+(coord(2)*N_proc(2)))*d_sc(2)
+ do i = 1, N_proc(1)
+ sX = (i-1+(coord(1)*N_proc(1)))*d_sc(1)
+ good_scal(i,j,k) = cos(3*2*M_PI*(sZ+vect_dir(3)*scal3D(i,j,k))/length(3))
+ good_scal(i,j,k) = good_scal(i,j,k)*cos(2*2*M_PI*(sY+vect_dir(2)*scal3D(i,j,k))/length(2))
+ good_scal(i,j,k) = good_scal(i,j,k)*cos(2*M_PI*(sX+vect_dir(1)*scal3D(i,j,k))/length(1))
+ scal3D(i,j,k) = cos(3*2*M_PI*sZ/length(3))
+ scal3D(i,j,k) = scal3D(i,j,k)*cos(2*2*M_PI*sY/length(2))
+ scal3D(i,j,k) = scal3D(i,j,k)*cos(2*M_PI*sX/length(1))
+ end do
+ end do
+ end do
+
+end subroutine scal_velo_init_part
+
+!> Compute a velocity field wich produce 2 tagged block during an advection step
+!! with the solver based on particle method
+!! @param[in] pos = relative position along current direction
+!! @param[in] shift = shift (in number of mesh)
+!! @param[in] cfl = time step/space step
+!! @param[in] direction = current direction
+!! @return res = velocity field
+function compute_velo_tag(pos, shift, cfl, direction) result(res)
+
+ ! Topology
+ use cart_topology
+ ! Solver information
+ use advec_common
+ ! Test tools
+ use test_common
+
+ real(WP), intent(in) :: pos, cfl
+ integer, intent(in) :: shift, direction
+ real(WP) :: res
+ real(WP) :: pos_abs ! absolute position (i,j,k are relative position in the current processus)
+ integer :: ind_tag_bl, ind_tag_p
+
+ ind_tag_bl = (nb_proc_dim(direction)*(N(direction)/bl_size)/3)! - (bl_number(direction)*coord(direction))
+ ind_tag_p = (ind_tag_bl-1)*bl_size + bl_size/2 + 1
+
+ pos_abs = pos + coord(direction)*N_proc(direction)
+
+ res = shift/cfl
+ if ((pos_abs >= ind_tag_p).and.(pos_abs < N(direction))) then
+ res = res + 0.8*(1.0-(pos_abs-ind_tag_p)/(N(direction)-ind_tag_p))/cfl
+ end if
+
+end function compute_velo_tag
+
+end module advec_aux_init
diff --git a/CodesEnVrac/LEGI/test/src/Test_advec/advec_main.f90 b/CodesEnVrac/LEGI/test/src/Test_advec/advec_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c7f69bf8d0fa43399adfd5ec3c4fc929c35dcc7f
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_advec/advec_main.f90
@@ -0,0 +1,146 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : advec_main
+!
+! DESCRIPTION:
+!> This program use the function implemented in the module advec_aux to
+!! test the advection solver.
+!!
+!! @details
+!! All these test are unit test : they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular
+!! solver
+!! The following test are included :
+!! 1 -> advec a ball with a constant velocity
+!! 2 -> advec a ball with a spheric velocity field (the ball turns)
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program advec_main
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ ! Test procedures
+ use test_common
+ use advec_aux
+ use advec_aux_common
+
+ implicit none
+
+ logical :: error = .false. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc ! number of processus
+ integer :: i ! some boucle indice
+
+ ! ===== Initialisation =====
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .false.
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ if (mod(100, nb_proc)/=0) then
+ stop 'wrong number of processes : it have to divide 100'
+ end if
+ call cart_create((/ nb_proc, 1 /), ierr)
+ call mesh_default()
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+
+ ! ===== Test about procedures involved in remeshing process =====
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('particle method - remeshing', rank_world)
+
+ ! Does it well compute who communicate with who during remeshing ?
+ error = test_part_AC_obtain_senders()
+ call test_status(error, 'obtain_senders sans shift', rank_world)
+ error = test_part_AC_obtain_senders(1)
+ call test_status(error, 'obtain_senders avec shift', rank_world)
+ error = test_part_AC_obtain_senders(3*nb_proc_dim(2)+2)
+ call test_status(error, 'obtain_senders avec large shift', rank_world)
+
+verbose_more = .true.
+ if (nb_proc_dim(2)>1) then
+ ! The remeshing are done in a buffer. Is it well re-distribuate on processes ?
+ do i = 0, min(4, nb_proc-1)
+ error = test_part_AC_bufferToScalar_Deb(i)
+ call test_status(error, 'bufferToScalar deb, no shift, rank =', i, rank_world)
+ error = test_part_AC_bufferToScalar_Deb(i,1)
+ call test_status(error, 'bufferToScalar deb,shift; rank =', i, rank_world)
+ end do
+ error = test_part_AC_bufferToScalar()
+ call test_status(error, 'bufferToScalar sans shift', rank_world)
+ error = test_part_AC_bufferToScalar(1)
+ call test_status(error, 'bufferToScalar avec shift', rank_world)
+ error = test_part_AC_bufferToScalar(3*nb_proc_dim(2)+2)
+ call test_status(error, 'bufferToScalar avec large shift', rank_world)
+
+ ! Test remeshing of untagged particles
+ error = test_part_remesh_no_tag()
+ call test_status(error, 'remeshing of cst field advected a cst v', rank_world)
+
+ error = test_part_remesh_no_tag('translation_field')
+ call test_status(error, 'remeshing of uncst field advected a cst v', rank_world)
+ else
+ call test_status(error, 'only one proc along Y, no test on remesh', rank_world)
+ end if
+verbose_more = .false.
+
+ ! ===== Test about procedures involved in computation of particles advection =====
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('particle method - particle advection', rank_world)
+
+ ! Test auxiliary procedures
+ error = test_part_AC_obtain_recevers()
+ call test_status(error, 'AC_obtain_recevers', rank_world)
+
+
+ ! Test velocity interpolation
+ error = test_part_AC_interpol_velocity(2, Y_comm, 0)
+ call test_status(error, 'velocity interpolation along Y, no shift', rank_world)
+ error = test_part_AC_interpol_velocity(2, Y_comm, 1)
+ call test_status(error, 'velocity interpolation along Y, shift', rank_world)
+
+ ! ===== Test others =====
+ call test_title('particle method - tag and bloc type', rank_world)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ error = test_part_AC_type_and_block_O2()
+ call test_status(error, 'determine block type and tag particles', rank_world)
+
+ ! ===== Test solvers =====
+
+ ! Test devoted to solver based on particles method
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('particle method - advection test', rank_world)
+ error = test_part_advecO2('left')
+ call test_status(error, 'advection - left block, no tag', rank_world)
+ error = test_part_advecO2()
+ call test_status(error, 'advection - center block, no tag', rank_world)
+
+ ! Generic test
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('generic advection test - V=constant', rank_world)
+ error = test_advecY()
+ call test_status(error, 'advection of a constant field', rank_world)
+ error = test_advecY('translation_field')
+ call test_status(error, 'translation of a unconstant field', rank_world)
+
+ call mpi_finalize(ierr)
+
+end program advec_main
+
diff --git a/CodesEnVrac/LEGI/test/src/Test_topo/topo_aux.f90 b/CodesEnVrac/LEGI/test/src/Test_topo/topo_aux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..02fe7ae93e7a50e11be838b5ad7670010723f200
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_topo/topo_aux.f90
@@ -0,0 +1,277 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: topo_aux
+!
+! DESCRIPTION:
+!> This module provides different tests to validate the topology and the
+!! interface with the different data structures.
+!!
+!! @details
+!! Different automatic test are developped in order to check the mesh creation
+!! and the interface between the two data structures (the one used for the
+!! particular method and the one from the spectral part).
+!! All these test are unit test : they return a logical value to check if
+!! the ierr version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!!
+!! The following test are included :
+!! 1 -> Initialise the topology, check the number of processes and
+!! the communicators.
+!! 2 -> Check the periodicity.
+!! 3 -> Check if the subgrid on each processus have the good size
+!! n -> (XXX todo) Test the interface between the data structure in the advection
+!! solver based on particular method and the one used in the rest of the
+! ierr.
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module topo_aux
+
+ use mpi
+ use cart_topology
+ use string
+ use precision
+ implicit none
+
+ real(WP), private :: epsilon_success = 1e-4 ! Error tolerance
+
+
+ ! Public procedures
+
+ ! ===== Test the topology =====
+ ! Public function
+ public :: test_topo_init
+ public :: test_topo_perio
+ public :: test_topo_submesh
+
+
+
+
+contains
+
+!> Test the topology initialisation
+!! @return success = logical success (= false if the ierr pass the test)
+!! @details
+!! Test the cartesian topology : check the number of processes and the
+!! communicators.
+function test_topo_init() result(success)
+
+ use test_common
+
+ logical :: success ! success status
+
+ integer :: ierr ! mpi success ierr
+ integer :: nb_proc ! total number of processus
+ integer :: nb_Y, nb_Z ! actual number of processus in each direction
+ integer, dimension(2) :: dims ! wanted number of processus in Y and Z direction
+
+ success = .true.
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ dims = (/ nb_proc, 1 /)
+ call cart_create(dims, ierr)
+
+ ! Check the number of process in each communicator
+ call mpi_comm_size(Y_comm, nb_Y, ierr)
+ if (nb_Y /= nb_proc) then
+ call test_substatus('number of processes in Y_comm', nb_Y, myrank)
+ call test_substatus('and it must be', nb_proc, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ call mpi_comm_size(Z_comm, nb_Z, ierr)
+ if (nb_Z /= 1) then
+ call test_substatus('number of processes in Z_comm', nb_Z, myrank)
+ call test_substatus('and it must be', 1, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! Compare it with the one saved in cart_topo
+ if (nb_Y /= nb_proc_dim(2)) then
+ call test_substatus('number of processes in Y_comm', nb_Y, myrank)
+ call test_substatus('and the solver beleave it is', nb_proc_dim(2), myrank)
+ success = .false.
+ end if
+ if (nb_Z /= nb_proc_dim(3)) then
+ call test_substatus('number of processes in Y_comm', nb_Z, myrank)
+ call test_substatus('and the solver beleave it is', nb_proc_dim(3), myrank)
+ success = .false.
+ end if
+
+ ! Return error = not succes
+ success = .not. success
+
+end function test_topo_init
+
+!> Check if it provide the right cartesian structure with a good periodicity
+!! @return success = logical success (= false if the ierr pass the test)
+function test_topo_perio() result(success)
+
+ use test_common
+
+ logical :: success ! success status
+
+ integer :: ierr ! mpi success ierr
+ integer :: rankP, rankN ! rank of previous and next (for shift)
+ integer :: nb_Y, nb_Z ! number of processus in each direction
+ integer, dimension(2) :: dims ! number of processus in Y and Z direction
+ integer, dimension(3) :: coord_bis ! coordonate of another processus
+ integer :: new_coord ! theoritical coordinate
+
+ success = .true.
+
+ ! Get the size
+ call mpi_comm_size(Y_comm, nb_Y, ierr)
+ call mpi_comm_size(Z_comm, nb_Z, ierr)
+
+ ! Shift along Y
+ ! Positive shift
+ call mpi_cart_shift(cart_comm, 2-1, 1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y-1 on rank', myrank, printer)
+ call test_substatus('theoritical Y-1', new_coord, printer)
+ call test_substatus('computed Y-1', coord_bis(2), printer)
+call test_substatus('X', coord_bis(1), printer)
+call test_substatus('Z', coord_bis(3), printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+1 on rank', myrank, printer)
+ success = .false.
+ end if
+ ! Negative shift
+ call mpi_cart_shift(cart_comm, 2-1, -1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y-(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('topo and periodicity along Y', success, myrank)
+
+ ! Shift along Z
+ ! Positive shift
+ call mpi_cart_shift(cart_comm, 3-1, 1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)-1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z-1 on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)+1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z+1 on rank', myrank, printer)
+ success = .false.
+ end if
+ ! Negative shift
+ call mpi_cart_shift(cart_comm, 3-1, -1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)-1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z+(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)+1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z-(-1)) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('topo and periodicity along Z', success, myrank)
+
+ ! Big shift
+ call mpi_cart_coords(cart_comm, myrank, 3, coord, ierr)
+ call mpi_cart_shift(cart_comm, 2-1, 1+2*Nb_Y, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y- on rank', myrank, printer)
+ call test_substatus('theoritical Y-', new_coord, printer)
+ call test_substatus('computed Y-', coord_bis(2), printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+ on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('huge shift along Y', success, myrank)
+
+ ! Return error = not success
+ success = .not.success
+
+end function test_topo_perio
+
+
+!> Test the construction of subdomain and the mesh size in each processus
+!! @return success = logical success (= false if the ierr pass the test)
+!! @details
+!! Check if the subgrid on each processus have the good size
+function test_topo_submesh() result(success)
+
+ use test_common
+
+ logical :: success
+ integer :: ierr ! mpi success code
+
+ success = .true.
+
+ call mesh_default()
+
+ ! Check the number of mesh
+ if (N_proc(1)/= 100) then
+ call test_substatus('local number of mesh along X', N_proc(1), myrank)
+ success = .false.
+ end if
+ if (N_proc(2)/= 100/nb_proc_dim(2)) then
+ call test_substatus('local number of mesh along Y', N_proc(2), myrank)
+ success = .false.
+ end if
+ if (N_proc(3)/= 100/nb_proc_dim(3)) then
+ call test_substatus('local number of mesh along Z', N_proc(3), myrank)
+ success = .false.
+ end if
+
+ ! Return error = not success
+ success = .not.success
+
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+end function test_topo_submesh
+
+
+end module topo_aux
diff --git a/CodesEnVrac/LEGI/test/src/Test_topo/topo_main.f90 b/CodesEnVrac/LEGI/test/src/Test_topo/topo_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b7d2dd8494075ea65d10a6a80584f2bd7b495be1
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/Test_topo/topo_main.f90
@@ -0,0 +1,59 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : topo_main
+!
+! DESCRIPTION:
+!> Test the cartesian topology and all the associated variable.
+!! test the advection solver.
+!! This program perform all the test include in "topo_aux". This module provide
+!! unit test, ie logical function wich return a logical error.
+!! There is a verbosity parameter to decide to print on screen the status of
+!! result of each test (and sub-test) or not.
+!!
+!! See topo_aux for a list of available test.
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program topo_main
+
+ use mpi
+ use topo_aux
+ use test_common
+
+ implicit none
+
+ logical :: error = .true. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc ! number of processus
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .true.
+
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_test_substatus(ierr, error, 'mpi initialization', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_init()
+ call test_status(error, '(mpi) topology initialisation', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_perio()
+ call test_status(error, 'periodicity', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_submesh()
+ call test_status(error, 'subdomain size', rank_world)
+
+ call mpi_finalize(ierr)
+
+end program topo_main
+
diff --git a/CodesEnVrac/LEGI/test/src/test_common.f90 b/CodesEnVrac/LEGI/test/src/test_common.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fa159b5cc0954befcf0327bb91e269072e3443bd
--- /dev/null
+++ b/CodesEnVrac/LEGI/test/src/test_common.f90
@@ -0,0 +1,411 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection
+!
+! DESCRIPTION:
+!> This module provide different tools useful to perform test.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module test_common
+
+ use string
+ use precision
+
+ implicit none
+
+ ! ===== Public variables =====
+ !> To print some status message during the test
+ logical :: verbose_test = .true.
+ !> More verbosity !
+ logical :: verbose_more = .true.
+ !> To choose wich processes lead the screen output
+ integer :: printer = 0
+
+ ! ===== Public procedure =====
+ ! - To print some information about the test (verbosity case)
+ public :: test_title
+ public :: test_status
+ public :: mpi_test_substatus
+ public :: test_substatus
+
+
+ ! ===== Private variables =====
+ !> Error tolerance
+ real(WP), private :: epsilon_success = 1e-4
+
+ ! ===== Interface =====
+ interface test_status
+ module procedure test_status_M, test_status_MI
+ end interface test_status
+
+ interface test_substatus
+ module procedure test_substatus_M, test_substatus_MI, test_substatus_MR &
+ & , test_substatus_ML, test_substatus_M3I
+ end interface test_substatus
+
+ interface test_check_success
+ module procedure test_check_success_S, test_check_success_F, &
+ & test_check_success_F2, test_check_success_F3, test_check_success_FI
+ end interface test_check_success
+
+
+
+contains
+
+!> Diffuse the error status and print the test status
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_title(message, rank)
+
+ use cart_topology
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ character(len=40) :: mess_bis ! message copy
+
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(A1,1X,A40)')'#', mess_bis
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_title
+
+
+!> Diffuse the error status and print the test status
+!! @param[in, out] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_status_M(error, message, rank)
+
+ use mpi
+ use cart_topology
+
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ character(len=40) :: mess_bis ! message copy
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(error .eqv. .true.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) error=.true.
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(5X,A2,2X,A40,X,A2,L2)')'->', mess_bis, '=', .not.error
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_status_M
+
+
+!> Diffuse the error status and print the test status
+!! @param[in, out] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] message_int = integer added to the information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_status_MI(error, message, message_int , rank)
+
+ use mpi
+ use cart_topology
+
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank, message_int
+
+ character(len=37) :: mess_bis ! message copy
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(error .eqv. .true.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) error=.true.
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(5X,A2,2X,A37,X,I2,X,A2,L2)')'->', mess_bis, message_int, '=', .not.error
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_status_MI
+
+
+!> Use a mpi error code to update the test status and print it
+!! @param[in] ierr = mpi error code
+!! @param[in] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine mpi_test_substatus(ierr, error, message, rank)
+
+ use mpi
+
+ integer, intent(in) :: ierr
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ if (ierr /= MPI_SUCCESS) then
+ error = .false.
+ end if
+
+ call test_substatus(message, error, rank)
+ error = .not. error
+
+end subroutine mpi_test_substatus
+
+!> Print a sub-status message
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_M(message, rank)
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40)')'+', message
+ end if
+
+end subroutine test_substatus_M
+
+
+!> Print a sub-status message and a integer
+!! @param[in] message = information message
+!! @param[in] i = integer to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_MI(message, i, rank)
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: i
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,I5)')'+', message, '=', i
+ end if
+
+end subroutine test_substatus_MI
+
+
+!> Print a sub-status message and a integer
+!! @param[in] message = information message
+!! @param[in] i = integer table of dimension 3 to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_M3I(message, i, rank)
+
+ character(len =*), intent(in) :: message
+ integer, dimension(3), intent(in) :: i
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,I3,X,A1,X,I3,X,A1,X,I3)')'+',message,'=',i(1),',',i(2),',',i(3)
+ end if
+
+end subroutine test_substatus_M3I
+
+
+!> Print a sub-status message and a real
+!! @param[in] message = information message
+!! @param[in] r = real to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_MR(message, r, rank)
+
+ use precision
+
+ character(len=* ), intent(in) :: message
+ real(WP), intent(in) :: r
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,F8.4)')'+', message, '=', r
+ end if
+
+end subroutine test_substatus_MR
+
+
+!> Print a sub-status message and a logical (after sending its value if false)
+!! @param[in] message = information message
+!! @param[in,out] l = logical to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_ML(message, l, rank)
+
+ use precision
+ use mpi
+ use cart_topology
+
+ character(len =*), intent(in) :: message
+ logical, intent(inout) :: l
+ integer, intent(in) :: rank
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(l .eqv. .false.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) l=.false.
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,L5)')'+', message, '=', l
+ end if
+
+end subroutine test_substatus_ML
+
+
+
+!> Check if the numerical success stay under a threshold - constant theoritical
+!! solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+subroutine test_check_success_S(scal1D, good_scal, success)
+
+ use precision
+ use cart_topology
+
+ real(WP), intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+
+ integer :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(scal1D - good_scal)
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', myrank)
+ call test_substatus('max scal0D', maxval(scal1D), myrank)
+ call test_substatus('min scal0D', minval(scal1D), myrank)
+ call test_substatus('and it must be', good_scal, myrank)
+ end if
+
+end subroutine test_check_success_S
+
+
+!> Check if two integer 2-dimensionnal table are equal.
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+subroutine test_check_success_FI(scal1D, good_scal, success)
+
+ use precision
+ use cart_topology
+
+ integer, dimension(:),intent(in) :: good_scal ! theoritical value of scal1D
+ integer, dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+
+ integer :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal1D - good_scal))
+
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', myrank)
+ call test_substatus('max scal1D', maxval(scal1D), myrank)
+ call test_substatus('min scal1D', minval(scal1D), myrank)
+ call test_substatus('max solution', maxval(good_scal), myrank)
+ end if
+
+end subroutine test_check_success_FI
+
+
+!> Check if the numerical success stay under a threshold - 1D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+subroutine test_check_success_F(scal1D, good_scal, success)
+
+ use precision
+ use cart_topology
+
+ real(WP), dimension(:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+
+ real(WP) :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal1D - good_scal))
+
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', myrank)
+ call test_substatus('max scal1D', maxval(scal1D), myrank)
+ call test_substatus('min scal1D', minval(scal1D), myrank)
+ call test_substatus('max solution', maxval(good_scal), myrank)
+ call test_substatus('min solution', minval(good_scal), myrank)
+ end if
+
+end subroutine test_check_success_F
+
+
+!> Check if the numerical success stay under a threshold - 2D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal2D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+subroutine test_check_success_F2(scal2D, good_scal, success)
+
+ use precision
+ use cart_topology
+
+ real(WP), dimension(:,:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:,:),intent(in) :: scal2D ! the computed scalar field
+ logical, intent(inout) :: success
+
+ real(WP) :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal2D - good_scal))
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', myrank)
+ call test_substatus('max scal2D', maxval(scal2D), myrank)
+ call test_substatus('min scal2D', minval(scal2D), myrank)
+ call test_substatus('max solution', maxval(good_scal), myrank)
+ call test_substatus('min solution', minval(good_scal), myrank)
+ end if
+
+end subroutine test_check_success_F2
+
+
+!> Check if the numerical success stay under a threshold - 3D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal3D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+subroutine test_check_success_F3(scal3D, good_scal, success)
+
+ use precision
+ use cart_topology
+
+ real(WP), dimension(:,:,:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:,:,:),intent(in) :: scal3D ! the computed scalar field
+ logical, intent(inout) :: success
+
+ real(WP) :: success_inf ! norm L_inf of the success
+
+integer, dimension(3) :: temp
+
+ success_inf = maxval(abs(scal3D - good_scal))
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', myrank)
+ temp = minloc(scal3D - good_scal)
+ call test_substatus('error min in', temp, myrank)
+ call test_substatus('scal3D', scal3D(temp(1), temp(2), temp(3)), myrank)
+ call test_substatus('sol', good_scal(temp(1), temp(2), temp(3)), myrank)
+ temp = maxloc(scal3D - good_scal)
+ call test_substatus('error max in', temp, myrank)
+ call test_substatus('scal3D', scal3D(temp(1), temp(2), temp(3)), myrank)
+ call test_substatus('sol', good_scal(temp(1), temp(2), temp(3)), myrank)
+ end if
+
+end subroutine test_check_success_F3
+
+
+end module test_common
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/CMake b/CodesEnVrac/NavierStokes3D-Penalization/CMake
new file mode 120000
index 0000000000000000000000000000000000000000..af160f9126941418c0041528616ca5e2b612707d
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/CMake
@@ -0,0 +1 @@
+../../CMake
\ No newline at end of file
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/CMakeLists.txt b/CodesEnVrac/NavierStokes3D-Penalization/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..29ae79e93de3e9d9f553a71a3617868410cc3390
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/CMakeLists.txt
@@ -0,0 +1,112 @@
+#=======================================================
+# cmake utility to compile and install NavierStokes3D
+#
+# F. Pérignon, oct 2011
+#
+#=======================================================
+
+# ============= Global cmake Settings =============
+# Set minimum version for cmake
+cmake_minimum_required(VERSION 2.8)
+# Set policy
+cmake_policy(VERSION 2.8)
+# Set cmake modules directory (i.e. the one which contains all user-defined FindXXX.cmake files among other things)
+set(CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/CMake)
+# Force out-of-source build
+include(OutOfSourceBuild)
+# Some usefull macros
+include(MyTools)
+
+# ============= Specific settings =============
+# Here we set all variables
+# required to compile and install the soft such as the name of
+# the library to be created, the place where we can find the sources,
+# the version number of the current package ...
+
+# User defined options
+option(VERBOSE_MODE "enable verbose mode for cmake exec. Default = on" ON)
+
+# cmake project name
+set(PROJECT_NAME NavierStokes3D)
+# --- Name for the package ---
+# This name will be used to install Parmes (library, headers, ...) and when another lib or soft will need to search for Parmes.
+set(PACKAGE_NAME "NS3D")
+# --- Set a version number for the package ---
+set(${PACKAGE_NAME}_version 1.0.0)
+# The list of all dirs containing sources to be compiled
+# Any file in those dirs will be used to create our lib/exec
+set(${PROJECT_NAME}_SRCDIRS
+ src
+ )
+# Matching expr for files to be compiled.
+set(EXTS *.cxx *.f90 *.f95)
+# Matching expr for headers
+set(EXTS_HDRS *.hpp *.h)
+# Note FP : we can also use cmake vars ${CMAKE_Fortran_SOURCE_FILE_EXTENSIONS} ${CMAKE_C_SOURCE_FILE_EXTENSIONS} ${CMAKE_CXX_SOURCE_FILE_EXTENSIONS}
+
+# ============= The project =============
+# Set project name and project languages
+# => this automatically defines:
+# - ${PROJECT_NAME}_BINARY_DIR : where you have run cmake, i.e. the place for compilation
+# - ${PROJECT_NAME}_SOURCE_DIR : where sources (.f and .h and this CMakeLists.txt) are located
+# Note that because of OutOfSourceBuild, binary_dir and source_dir must be different.
+project(${PROJECT_NAME} Fortran)
+
+# ============= Prepare compilation =============
+# Force a default build type if not provided by user
+# CMAKE_BUILD_TYPE = empty, Debug, Release, RelWithDebInfo or MinSizeRel.
+if (NOT CMAKE_BUILD_TYPE)
+ set (CMAKE_BUILD_TYPE RELEASE CACHE STRING "Choose the type of build, options are: None, Debug, Release, RelWithDebInfo or MinSizeRel." FORCE)
+endif (NOT CMAKE_BUILD_TYPE)
+
+# If the project uses Fortran ...
+# Set module files directory (i.e. where .mod will be created)
+set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/Modules)
+# To add compilation flags:
+# append_Fortran_FLAGS("-Wall")
+
+# ============= Source and header files list =============
+# We scan all files with matching extension in directories
+# containing sources.
+# Source and header files list:
+foreach(_DIR ${${PROJECT_NAME}_SRCDIRS})
+ set(_DIR_FILES)
+ foreach(_EXT ${EXTS}) # Source files
+ file(GLOB _DIR_FILES_EXT ${_DIR}/${_EXT})
+ if(_DIR_FILES_EXT)
+ list(APPEND ${PROJECT_NAME}_SRC ${_DIR_FILES_EXT})
+ endif()
+ endforeach()
+endforeach()
+
+# Add directories to those searched by compiler ...
+# -I
+include_directories(${${PROJECT_NAME}_SRCDIRS})
+include_directories(${CMAKE_Fortran_MODULE_DIRECTORY})
+
+add_executable(${PROJECT_NAME} ${${PROJECT_NAME}_SRC})
+# Libs to link with PROJECT__NAME
+target_link_libraries(${PROJECT_NAME} ${LIBS})
+
+# ============= RPATH =============
+# Concerning rpath see for example http://www.itk.org/Wiki/CMake_RPATH_handling
+
+# --------------------------------------------
+# do not skip the full RPATH for the build tree
+set(CMAKE_SKIP_BUILD_RPATH FALSE)
+# when building, don't use the install RPATH already
+# (but later on when installing)
+set(CMAKE_BUILD_WITH_INSTALL_RPATH FALSE)
+# the RPATH to be used when installing
+set(CMAKE_INSTALL_RPATH "${CMAKE_INSTALL_PREFIX}/lib")
+# add the automatically determined parts of the RPATH
+# which point to directories outside the build tree to the install RPATH
+set(CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE)
+
+# ============= Summary =============
+if(VERBOSE_MODE)
+ message(STATUS "====================== Summary ======================")
+ message(STATUS " Compiler : ${CMAKE_Fortran_COMPILER}")
+ message(STATUS " Sources are in : ${CMAKE_SOURCE_DIR}")
+ message(STATUS "====================== ======= ======================")
+endif()
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/examples/parameter b/CodesEnVrac/NavierStokes3D-Penalization/examples/parameter
new file mode 100644
index 0000000000000000000000000000000000000000..a43c24577bac6a639a0d6b94d5fc5e705b5beda2
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/examples/parameter
@@ -0,0 +1,12 @@
+-2.06441 2.06441 -3. 3. -2.06441 2.06441 ! xg xd yb yh zd zf
+33 33 33 !33 65 129 257!nx ny nz
+30. ! TFin
+1.D-8 !cutoff
+4 ! type bloc
+2 !longeur bloc
+"test.vtk" ! sortie fin vtk
+1.D-16 1.D6 1.D2 !lambda_flu lambda_sol lambda_por
+4.74833808D-03 (Re=210.6) 7.496251874D-03 (Re=133.4) !nu=1/Re
+"RES/test/omg_" "RES/test/vg_" "RES/test/chi.vtk" "RES/test/lambda.vtk" 2000000 !vtk
+"RES/test/test.res" "RES/test/test.drag" !coupe vitesse drag/lift
+0 200000 "RES/test/sauv.vtk" !num_suite (0non 1 oui) num_ite name_relance
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/make_test_fft b/CodesEnVrac/NavierStokes3D-Penalization/make_test_fft
new file mode 100644
index 0000000000000000000000000000000000000000..41385dc1eb01bd3d53bd3ddd99dce5d98ed63de5
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/make_test_fft
@@ -0,0 +1,23 @@
+#
+# Makefile
+#
+Compilateur = ifort -O0 -debug extended
+Programme = test_fft
+FILES = nrtype.f90 nrutil.f90 nr.f90 four3.f90 fourrow_3d.f90 rlft3.f90 four2.f90 fourrow.f90 rlft2.f90 test_fft.f90
+OBJS = $(patsubst %.f90, %.o, $(FILES))
+
+$(Programme): $(OBJS)
+ @echo edition de liens
+ @$(Compilateur) $(OBJS) -o $@
+
+%.o: %.f90
+ @echo compilation de $?
+ @$(Compilateur) -c $?
+
+clean:
+ @rm -f *.o *~ *.mod
+ @echo nettoyage
+
+clean_all:
+ @rm -f *.o *~ *.mod *exe *.out
+ @echo nettoyage
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/Unused/test_fft.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/Unused/test_fft.f90
new file mode 100644
index 0000000000000000000000000000000000000000..20cd10f39d1201a8475069627f31a6e419847e56
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/Unused/test_fft.f90
@@ -0,0 +1,1609 @@
+program test_fft
+ use nrtype
+ USE nrutil
+ USE nr
+ implicit none
+
+
+
+ !==============================
+ !test aller/retour
+ !==============================
+
+
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:,:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz
+!!$ real(SP),dimension(:,:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=4
+!!$ ny=4
+!!$ nz=4
+
+!!$ allocate (donne_init(1:nx,1:ny,1:nz),donne_fin(1:nx,1:ny,1:nz), spec1(1:nx/2,1:ny,1:nz), spec2(1:ny,1:nz) )
+!!$
+!!$ donne_init=3.
+!!$ fac=2./(nx*ny*nz)
+!!$
+!!$ print*, "forward"
+!!$ call rlft3(donne_init,spec1,spec2,1)
+!!$ print*,"backward"
+!!$ call rlft3(donne_fin,spec1,spec2,-1)
+!!$
+!!$ print*,"donne(1,1,1)",fac*donne_fin(1,1,1)
+!!$
+!!$ print*,"test"
+!!$ do k=1,nz
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ if (abs((fac*donne_fin(i,j,k))-donne_init(i,j,k))>0.001) print*,i,j,k,fac*donne_fin(i,j,k),donne_init(i,j,k)
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$ deallocate (donne_init,donne_fin,spec1,spec2)
+
+
+
+
+!!$
+!!$
+!!$ !===============================================================
+!!$ !test laplacien 2D: discrétisation ordre2, utilisation de four2
+!!$ !================================================================
+!!$ integer(I4B) :: nx,ny
+!!$ complex(SPC),dimension(:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,xg,xd,yb,yh,t1,t2,dx,dy,rn,rm
+!!$ complex(SPC),dimension(:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=32
+!!$ ny=32
+!!$
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$
+!!$
+!!$ dx=t1/(nx)
+!!$ dy=t2/(ny)
+!!$
+!!$
+!!$ allocate (psi(1:nx,1:ny),exa(1:nx,1:ny),f(1:nx,1:ny))
+!!$ allocate (spec1(1:nx,1:ny),spec_exa1(1:nx,1:ny))
+!!$
+!!$ !nx+1 point mais le dernier = premier par sym
+!!$
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ f(i,j)=-(4.*pi**2*exa(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ spec1=f
+!!$ spec_exa1=exa
+!!$
+!!$
+!!$ !fft forward
+!!$ call four2(spec1,1)
+!!$ call four2(spec_exa1,1)
+!!$
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$
+!!$ do n=1,ny
+!!$ do m=1,nx
+!!$
+!!$ spec1(m,n)=dx**2*spec1(m,n)/(2.*(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)-2.))
+!!$ ! le premier mode correspond à l'integrale de la masse: conservee pour un ecoulement periodique
+!!$ if ((m==1).and.(n==1)) spec1(m,n)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ print*,"erreur spectre"
+!!$ print*,maxval(abs(spec_exa1-spec1)),maxloc(abs(spec_exa1-spec1))
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=1./(nx*ny)
+!!$ call four2(spec1,-1)
+!!$ psi=fac*spec1
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$ print*,"dx**2",dx**2
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1)
+
+
+
+
+!!$ !===============================================================
+!!$ !test laplacien 2D: discretisation ordre2, utilisation de rlft2
+!!$ !================================================================
+!!$ integer(I4B) :: nx,ny
+!!$ real(SP),dimension(:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,xg,xd,yb,yh,t1,t2,dx,dy
+!!$ real(SP),dimension(:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=256
+!!$ ny=256
+!!$
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$
+!!$
+!!$ dx=t1/(nx)
+!!$ dy=t2/(ny)
+!!$
+!!$
+!!$ allocate (psi(1:nx,1:ny),exa(1:nx,1:ny),f(1:nx,1:ny))
+!!$ allocate (spec1(1:nx/2,1:ny), spec2(1:ny),spec_exa1(1:nx/2,1:ny), spec_exa2(1:ny) )
+!!$
+!!$ !nx+1 point mais le dernier = premier par sym
+!!$
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ f(i,j)=-(4.*pi**2*exa(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft forward
+!!$ call rlft2(f,spec1,spec2,1)
+!!$ call rlft2(exa,spec_exa1,spec_exa2,1)
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$ !calcul de la solution dans l'espace des frequences (discretisation d'ordre2 du laplacien)
+!!$ m=nx/2+1
+!!$ do n=1,ny
+!!$ spec2(n)=0.5*dx**2*spec2(n)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)-2.)
+!!$ end do
+!!$
+!!$ do n=1,ny
+!!$ do m=1,nx/2
+!!$
+!!$ spec1(m,n)=0.5*dx**2*spec1(m,n)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)-2.)
+!!$ if ((n==1).and.(m==1)) spec1(m,n)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny)
+!!$ call rlft2(psi,spec1,spec2,-1)
+!!$ psi=fac*psi
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$ print*,"dx**2",dx**2
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1,spec2,spec_exa2)
+
+
+
+
+
+!!$ !===============================================================
+!!$ !test laplacien 3D: discretisation ordre2, utilisation de rlft3
+!!$ !================================================================
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:,:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz
+!!$ real(SP),dimension(:,:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=64
+!!$ ny=64
+!!$ nz=64
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$ zd=-1.
+!!$ zf=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$ t3=zf-zd
+!!$
+!!$
+!!$ dx=t1/nx
+!!$ dy=t2/ny
+!!$ dz=t3/nz
+!!$
+!!$ if ((dx/=dy).or.(dx/=dz)) then
+!!$ print*,"attention dx=dy=dz"
+!!$ stop
+!!$ end if
+!!$
+!!$ allocate (psi(1:nx,1:ny,1:nz),exa(1:nx,1:ny,1:nz),f(1:nx,1:ny,1:nz))
+!!$ allocate (spec1(1:nx/2,1:ny,1:nz), spec2(1:ny,1:nz),spec_exa1(1:nx/2,1:ny,1:nz), spec_exa2(1:ny,1:nz) )
+!!$
+!!$ do k=1,nz
+!!$ z=zd+(k-1)*dz
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+!!$ f(i,j,k)=-(4.*pi**2*exa(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft forward
+!!$ call rlft3(f,spec1,spec2,1)
+!!$ call rlft3(exa,spec_exa1,spec_exa2,1)
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$ !calcul de la solution dans l'espace des frequences (discretisation d'ordre2 du laplacien)
+!!$ m=nx/2+1
+!!$ do p=1,nz
+!!$ do n=1,ny
+!!$ spec2(n,p)=0.5*dx**2*spec2(n,p)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.)
+!!$ end do
+!!$ end do
+!!$
+!!$ do p=1,nz
+!!$ do n=1,ny
+!!$ do m=1,nx/2
+!!$ spec1(m,n,p)=0.5*dx**2*spec1(m,n,p)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.)
+!!$ if ((n==1).and.(m==1).and.(p==1)) spec1(m,n,p)=0.
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny*nz)
+!!$ call rlft3(psi,spec1,spec2,-1)
+!!$ psi=fac*psi
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$ print*,"dx**2",dx**2
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1,spec2,spec_exa2)
+!!$
+
+
+
+
+
+
+!!$ !===============================================================
+!!$ !test laplacien 2D: utilisation de four2
+!!$ !================================================================
+!!$ integer(I4B) :: nx,ny
+!!$ complex(SPC),dimension(:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,xg,xd,yb,yh,t1,t2,dx,dy,kx,ky
+!!$ complex(SPC),dimension(:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=8
+!!$ ny=8
+!!$
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$
+!!$
+!!$ dx=t1/(nx)
+!!$ dy=t2/(ny)
+!!$
+!!$
+!!$ allocate (psi(1:nx,1:ny),exa(1:nx,1:ny),f(1:nx,1:ny))
+!!$ allocate (spec1(1:nx,1:ny),spec_exa1(1:nx,1:ny))
+!!$
+!!$ !nx+1 point mais le dernier = premier par sym
+!!$
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ f(i,j)=-(4.*pi**2*exa(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ spec1=f
+!!$ spec_exa1=exa
+!!$
+!!$
+!!$ !fft forward
+!!$ call four2(spec1,1)
+!!$ call four2(spec_exa1,1)
+!!$
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$ do n=1,ny
+!!$ do m=1,nx
+!!$
+!!$ !attention au rangement des frequences: >0 puis 0 puis <0
+!!$
+!!$ if ( (m-1)<=(nx/2) ) then
+!!$ kx=(m-1)/t1
+!!$ else
+!!$ kx=(m-1-nx)/t1
+!!$ end if
+!!$
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$
+!!$ spec1(m,n)=-spec1(m,n)/(4.*pi**2*(kx**2+ky**2))
+!!$ if ((kx==0).and.(ky==0)) spec1(m,n)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$
+!!$ print*,"erreur spectre"
+!!$ print*,maxval(abs(spec_exa1-spec1)),maxloc(abs(spec_exa1-spec1))
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=1./(nx*ny)
+!!$ call four2(spec1,-1)
+!!$ psi=fac*spec1
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1)
+!!$
+
+
+
+!!$
+!!$ !===============================================================
+!!$ !test laplacien 2D: utilisation de rlft2
+!!$ !================================================================
+!!$ integer(I4B) :: nx,ny
+!!$ complex(SPC),dimension(:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,xg,xd,yb,yh,t1,t2,dx,dy,kx,ky
+!!$ real(SP),dimension(:,:),allocatable :: psi,f,exa
+!!$
+!!$ nx=8
+!!$ ny=8
+!!$
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$
+!!$
+!!$ dx=t1/(nx)
+!!$ dy=t2/(ny)
+!!$
+!!$
+!!$ allocate (psi(1:nx,1:ny),exa(1:nx,1:ny),f(1:nx,1:ny))
+!!$ allocate (spec1(1:nx/2,1:ny), spec2(1:ny),spec_exa1(1:nx/2,1:ny), spec_exa2(1:ny) )
+!!$
+!!$ !nx+1 point mais le dernier = premier par sym
+!!$
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ f(i,j)=-(4.*pi**2*exa(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ !fft forward
+!!$ call rlft2(f,spec1,spec2,1)
+!!$ call rlft2(exa,spec_exa1,spec_exa2,1)
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$ do n=1,ny
+!!$ do m=1,nx/2
+!!$
+!!$ kx=(m-1)/t1
+!!$
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$ spec1(m,n)=-spec1(m,n)/(4.*pi**2*(kx**2+ky**2))
+!!$ if ((kx==0).and.(ky==0)) spec1(m,n)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ m=nx/2+1
+!!$ do n=1,ny
+!!$
+!!$ kx=(m-1)/t1
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$ spec2(n)=-spec2(n)/(4.*pi**2*(kx**2+ky**2))
+!!$ if ((kx==0).and.(ky==0)) spec2(n)=0.
+!!$ end do
+!!$
+!!$
+!!$ print*,"spec_exa"
+!!$ print*,spec_exa1
+!!$ print*,spec_exa2
+!!$ print*,"spec"
+!!$ print*,spec1
+!!$ print*,spec2
+!!$
+!!$
+!!$ print*,"erreur spectre"
+!!$ print*,maxval(abs(spec_exa1-spec1)),maxloc(abs(spec_exa1-spec1))
+!!$ print*,maxval(abs(spec_exa2-spec2)),maxloc(abs(spec_exa2-spec2))
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny)
+!!$ call rlft2(psi,spec1,spec2,-1)
+!!$ psi=fac*psi
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1)
+!!$
+!!$
+
+!!$ !===============================================================
+!!$ !test laplacien 3D: utilisation de rlft3
+!!$ !================================================================
+!!$
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec1,spec_exa1
+!!$ complex(SPC),dimension(:,:),allocatable :: spec2,spec_exa2
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz,kx,ky,kz
+!!$ real(SP),dimension(:,:,:),allocatable :: psi,f,exa
+!!$
+!!$
+!!$ nx=8
+!!$ ny=64
+!!$ nz=32
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$ zd=-1.
+!!$ zf=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$ t3=zf-zd
+!!$
+!!$
+!!$ dx=t1/nx
+!!$ dy=t2/ny
+!!$ dz=t3/nz
+!!$
+!!$
+!!$ allocate (psi(1:nx,1:ny,1:nz),exa(1:nx,1:ny,1:nz),f(1:nx,1:ny,1:nz))
+!!$ allocate (spec1(1:nx/2,1:ny,1:nz), spec2(1:ny,1:nz),spec_exa1(1:nx/2,1:ny,1:nz), spec_exa2(1:ny,1:nz) )
+!!$
+!!$ do k=1,nz
+!!$ z=zd+(k-1)*dz
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ exa(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+!!$ f(i,j,k)=-(4.*pi**2*exa(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft forward
+!!$ call rlft3(f,spec1,spec2,1)
+!!$ call rlft3(exa,spec_exa1,spec_exa2,1)
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$ !calcul de la solution dans l'espace des frequences (discretisation d'ordre2 du laplacien)
+!!$ m=nx/2+1
+!!$ do p=1,nz
+!!$ do n=1,ny
+!!$
+!!$ kx=(m-1)/t1
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$
+!!$ spec2(n,p)=-spec2(n,p)/(4.*pi**2*(kx**2+ky**2+kz**2))
+!!$ if ((kx==0).and.(ky==0).and.(kz==0)) spec2(n,p)=0.
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ do p=1,nz
+!!$ do n=1,ny
+!!$ do m=1,nx/2
+!!$
+!!$
+!!$ kx=(m-1)/t1
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$
+!!$
+!!$ spec1(m,n,p)=-spec1(m,n,p)/(4.*pi**2*(kx**2+ky**2+kz**2))
+!!$ if ((kx==0).and.(ky==0).and.(kz==0)) spec1(m,n,p)=0.
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny*nz)
+!!$ call rlft3(psi,spec1,spec2,-1)
+!!$ psi=fac*psi
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psi-exa)),maxloc(abs(psi-exa))
+!!$
+!!$
+!!$ deallocate (psi,exa,f)
+!!$ deallocate(spec1,spec_exa1,spec2,spec_exa2)
+
+
+
+
+
+ !===============================================================
+ !test laplacien 2D: utilisation de four2 calcul champ vitesse
+ !================================================================
+!!$ integer(I4B) :: nx,ny
+!!$ complex(SPC),dimension(:,:),allocatable :: spec1x,spec1y,spec1z
+!!$ complex(SPC),dimension(:,:),allocatable :: spec_exa1x,spec_exa1y,spec_exa1z
+!!$ complex(SPC),dimension(:),allocatable :: spec2x,spec2y,spec2z
+!!$ complex(SPC),dimension(:),allocatable :: spec_exa2x,spec_exa2y,spec_exa2z
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,xg,xd,yb,yh,t1,t2,dx,dy,kx,ky
+!!$ complex(SPC),dimension(:,:),allocatable :: psix,fx,exax,psiy,fy,exay,psiz,fz,exaz
+!!$
+!!$ nx=8
+!!$ ny=8
+!!$
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$
+!!$
+!!$ dx=t1/(nx)
+!!$ dy=t2/(ny)
+!!$
+!!$
+!!$ allocate (psix(1:nx,1:ny),exax(1:nx,1:ny),fx(1:nx,1:ny))
+!!$ allocate (psiy(1:nx,1:ny),exay(1:nx,1:ny),fy(1:nx,1:ny))
+!!$ allocate (spec1x(1:nx,1:ny),spec_exa1x(1:nx,1:ny))
+!!$ allocate (spec1y(1:nx,1:ny),spec_exa1y(1:nx,1:ny))
+!!$
+!!$ !nx+1 point mais le dernier = premier par sym
+!!$
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ psix(i,j)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)
+!!$ psiy(i,j)=sin(2.*pi*x/t1)*sin(2.*pi*y/t2)
+!!$
+!!$ fx(i,j)=-(4.*pi**2*psix(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$ fy(i,j)=-(4.*pi**2*psiy(i,j)*(t2**2+t1**2))/((t1*t2)**2)
+!!$
+!!$ exax(i,j)=2.*pi*cos(2.*pi*x/t1)*sin(2.*pi*y/t2)*(t1+t2)/(t1*t2)
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ spec1x=fx
+!!$ spec1y=fy
+!!$
+!!$ !poisson
+!!$ !spec_exa1x=psix
+!!$ !spec_exa1y=psiy
+!!$
+!!$ !vitesse
+!!$ spec_exa1x=exax
+!!$ spec_exa1y=exax
+!!$
+!!$
+!!$ !fft forward
+!!$ call four2(spec1x,1)
+!!$ call four2(spec_exa1x,1)
+!!$ call four2(spec1y,1)
+!!$ call four2(spec_exa1y,1)
+!!$
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$ do n=1,ny
+!!$ do m=1,nx
+!!$
+!!$ !attention au rangement des frequences: >0 puis 0 puis <0
+!!$
+!!$ if ( (m-1)<=(nx/2) ) then
+!!$ kx=(m-1)/t1
+!!$ else
+!!$ kx=(m-1-nx)/t1
+!!$ end if
+!!$
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$ !poisson
+!!$ !spec1x(m,n)=-spec1x(m,n)/(4.*pi**2*(kx**2+ky**2))
+!!$ !if ((kx==0).and.(ky==0)) spec1x(m,n)=0.
+!!$ !spec1y(m,n)=-spec1y(m,n)/(4.*pi**2*(kx**2+ky**2))
+!!$ !if ((kx==0).and.(ky==0)) spec1y(m,n)=0.
+!!$
+!!$ !poisson+vitesse
+!!$ spec1x(m,n)=-2.*pi*cmplx(0.,1.)*(-kx*spec1y(m,n)/(4.*pi**2*(kx**2+ky**2)))&
+!!$ -2.*pi*cmplx(0.,1.)*(ky*spec1x(m,n)/(4.*pi**2*(kx**2+ky**2)))
+!!$ if ((kx==0).and.(ky==0)) spec1x(m,n)=0.
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$
+!!$ print*,"erreur spectre"
+!!$ print*,maxval(abs(spec_exa1x-spec1x)),maxloc(abs(spec_exa1x-spec1x))
+!!$ !print*,maxval(abs(spec_exa1y-spec1y)),maxloc(abs(spec_exa1y-spec1y))
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=1./(nx*ny)
+!!$
+!!$ !poisson
+!!$ !call four2(spec1x,-1)
+!!$ !exax=fac*spec1x
+!!$ !call four2(spec1y,-1)
+!!$ !exay=fac*spec1y
+!!$
+!!$ !vitesse
+!!$ call four2(spec1x,-1)
+!!$ psix=fac*spec1x
+!!$
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psix-exax)),maxloc(abs(psix-exax))
+!!$ !print*,maxval(abs(psiy-exay)),maxloc(abs(psiy-exay))
+!!$
+!!$
+!!$ deallocate (psix,exax,fx)
+!!$ deallocate(spec1x,spec_exa1x)
+!!$ deallocate (psiy,exay,fy)
+!!$ deallocate(spec1y,spec_exa1y)
+!!$
+!!$
+!!$
+!!$
+!!$
+ !===============================================================
+ !test laplacien + champ de vitesse 3D: utilisation de four3
+ !================================================================
+
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec1x, spec1y, spec1z
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec1xn, spec1yn, spec1zn
+!!$ complex(SPC),dimension(:,:),allocatable :: spec2x, spec2y, spec2z
+!!$ complex(SPC),dimension(:,:,:),allocatable :: spec_exa1x, spec_exa1y, spec_exa1z
+!!$ complex(SPC),dimension(:,:),allocatable :: spec_exa2x, spec_exa2y, spec_exa2z
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz,kx,ky,kz,r2,coeff
+!!$ real(SP),dimension(:,:,:),allocatable :: psix,psiy,psiz,fx,fy,fz,exax,exay,exaz
+!!$
+!!$
+!!$ nx=4
+!!$ ny=4
+!!$ nz=4
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$ zd=-1.
+!!$ zf=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$ t3=zf-zd
+!!$
+!!$
+!!$ dx=t1/nx
+!!$ dy=t2/ny
+!!$ dz=t3/nz
+!!$
+!!$
+!!$ allocate (psix(1:nx,1:ny,1:nz),exax(1:nx,1:ny,1:nz),fx(1:nx,1:ny,1:nz))
+!!$ allocate (psiy(1:nx,1:ny,1:nz),exay(1:nx,1:ny,1:nz),fy(1:nx,1:ny,1:nz))
+!!$ allocate (psiz(1:nx,1:ny,1:nz),exaz(1:nx,1:ny,1:nz),fz(1:nx,1:ny,1:nz))
+!!$ allocate (spec1x(1:nx,1:ny,1:nz),spec1xn(1:nx,1:ny,1:nz) )
+!!$ allocate (spec1y(1:nx,1:ny,1:nz),spec1yn(1:nx,1:ny,1:nz) )
+!!$ allocate (spec1z(1:nx,1:ny,1:nz),spec1zn(1:nx,1:ny,1:nz) )
+!!$ allocate (spec_exa1x(1:nx,1:ny,1:nz) )
+!!$ allocate (spec_exa1y(1:nx,1:ny,1:nz) )
+!!$ allocate (spec_exa1z(1:nx,1:ny,1:nz) )
+!!$
+!!$
+!!$ do k=1,nz
+!!$ z=zd+(k-1)*dz
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ !psi
+!!$ psix(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+!!$ psiy(i,j,k)=sin(2.*pi*x/t1)*sin(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$ psiz(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$
+!!$ !vitesse
+!!$ exax(i,j,k)=-2.*pi*sin(2.*pi*y/t2)*(cos(2.*pi*x/t1)*sin(2.*pi*z/t3)*t3+sin(2.*pi*x/t1)*cos(2.*pi*z/t3)*t2)/(t2*t3)
+!!$ exay(i,j,k)=-2.*pi*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)*(cos(2.*pi*x/t1)*t1-sin(2.*pi*x/t1)*t3)/(t1*t3)
+!!$ exaz(i,j,k)=2.*pi*sin(2.*pi*y/t2)*cos(2.*pi*x/t1)*(sin(2.*pi*z/t3)*t2+cos(2.*pi*z/t3)*t1)/(t2*t1)
+!!$
+!!$ !-omega
+!!$ fx(i,j,k)=-(4.*pi**2*psix(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fy(i,j,k)=-(4.*pi**2*psiy(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fz(i,j,k)=-(4.*pi**2*psiz(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$ spec1x=fx
+!!$ spec1y=fy
+!!$ spec1z=fz
+!!$
+!!$ spec_exa1x=exax
+!!$ spec_exa1y=exay
+!!$ spec_exa1z=exaz
+!!$
+!!$ !fft forward
+!!$ call four3(spec1x,1)
+!!$ call four3(spec1y,1)
+!!$ call four3(spec1z,1)
+!!$
+!!$ call four3(spec_exa1x,1)
+!!$ call four3(spec_exa1y,1)
+!!$ call four3(spec_exa1z,1)
+!!$
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$
+!!$ do p=1,nz
+!!$ do n=1,ny
+!!$ do m=1,nx
+!!$
+!!$ if ( (m-1)<=(nx/2) ) then
+!!$ kx=(m-1)/t1
+!!$ else
+!!$ kx=(m-1-nx)/t1
+!!$ end if
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$
+!!$ r2=kx**2+ky**2+kz**2
+!!$
+!!$
+!!$ !poisson+vitesse
+!!$ spec1xn(m,n,p)=-2.*pi*cmplx(0.,1.)*(-ky*spec1z(m,n,p)/(4.*pi**2*r2))&
+!!$ -2.*pi*cmplx(0.,1.)*(kz*spec1y(m,n,p)/(4.*pi**2*r2))
+!!$ if ((r2==0)) spec1xn(m,n,p)=0.
+!!$
+!!$ spec1yn(m,n,p)=-2.*pi*cmplx(0.,1.)*(-kz*spec1x(m,n,p)/(4.*pi**2*r2))&
+!!$ -2.*pi*cmplx(0.,1.)*(kx*spec1z(m,n,p)/(4.*pi**2*r2))
+!!$ if ((r2==0)) spec1yn(m,n,p)=0.
+!!$
+!!$
+!!$ spec1zn(m,n,p)=-2.*pi*cmplx(0.,1.)*(-kx*spec1y(m,n,p)+ky*spec1x(m,n,p))/(4.*pi**2*r2)
+!!$ if ((r2==0)) spec1zn(m,n,p)=0.
+!!$
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ print*,"erreur spectre"
+!!$ print*,maxval(abs(spec_exa1x-spec1xn)),maxloc(abs(spec_exa1x-spec1xn))
+!!$ print*,maxval(abs(spec_exa1y-spec1yn)),maxloc(abs(spec_exa1y-spec1yn))
+!!$ print*,maxval(abs(spec_exa1z-spec1zn)),maxloc(abs(spec_exa1z-spec1zn))
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=1./(nx*ny*nz)
+!!$
+!!$ call four3(spec1xn,-1)
+!!$ call four3(spec1yn,-1)
+!!$ call four3(spec1zn,-1)
+!!$
+!!$ psix=fac*spec1xn
+!!$ psiy=fac*spec1yn
+!!$ psiz=fac*spec1zn
+!!$
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psix-exax)),maxloc(abs(psix-exax))
+!!$ print*,maxval(abs(psiy-exay)),maxloc(abs(psiy-exay))
+!!$ print*,maxval(abs(psiz-exaz)),maxloc(abs(psiz-exaz))
+!!$
+!!$
+!!$ deallocate (psix,exax,fx)
+!!$ deallocate (psiy,exay,fy)
+!!$ deallocate (psiz,exaz,fz)
+!!$ deallocate(spec1x,spec1xn)
+!!$ deallocate(spec1y,spec1yn)
+!!$ deallocate(spec1z,spec1zn)
+!!$ deallocate(spec_exa1x)
+!!$ deallocate(spec_exa1y)
+!!$ deallocate(spec_exa1z)
+!!$
+
+ !===============================================================
+ !test laplacien + champ de vitesse 3D: utilisation de rlft3
+ !================================================================
+!!$
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: sf1x, sf1y, sf1z
+!!$ complex(SPC),dimension(:,:,:),allocatable :: su1x, su1y, su1z
+!!$ complex(SPC),dimension(:,:),allocatable :: sf2x, sf2y, sf2z
+!!$ complex(SPC),dimension(:,:),allocatable :: su2x, su2y, su2z
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz,kx,ky,kz,r2,coeff
+!!$ real(SP),dimension(:,:,:),allocatable :: psix,psiy,psiz,fx,fy,fz,exax,exay,exaz
+!!$
+!!$
+!!$ nx=8
+!!$ ny=32
+!!$ nz=16
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$ zd=-1.
+!!$ zf=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$ t3=zf-zd
+!!$
+!!$
+!!$ dx=t1/nx
+!!$ dy=t2/ny
+!!$ dz=t3/nz
+!!$
+!!$
+!!$ allocate (psix(1:nx,1:ny,1:nz),exax(1:nx,1:ny,1:nz),fx(1:nx,1:ny,1:nz))
+!!$ allocate (psiy(1:nx,1:ny,1:nz),exay(1:nx,1:ny,1:nz),fy(1:nx,1:ny,1:nz))
+!!$ allocate (psiz(1:nx,1:ny,1:nz),exaz(1:nx,1:ny,1:nz),fz(1:nx,1:ny,1:nz))
+!!$ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+!!$ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+!!$ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+!!$
+!!$
+!!$ do k=1,nz
+!!$ z=zd+(k-1)*dz
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ !psi
+!!$ psix(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+!!$ psiy(i,j,k)=sin(2.*pi*x/t1)*sin(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$ psiz(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$
+!!$ !vitesse
+!!$ exax(i,j,k)=-2.*pi*sin(2.*pi*y/t2)*(cos(2.*pi*x/t1)*sin(2.*pi*z/t3)*t3+sin(2.*pi*x/t1)*cos(2.*pi*z/t3)*t2)/(t2*t3)
+!!$ exay(i,j,k)=-2.*pi*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)*(cos(2.*pi*x/t1)*t1-sin(2.*pi*x/t1)*t3)/(t1*t3)
+!!$ exaz(i,j,k)=2.*pi*sin(2.*pi*y/t2)*cos(2.*pi*x/t1)*(sin(2.*pi*z/t3)*t2+cos(2.*pi*z/t3)*t1)/(t2*t1)
+!!$
+!!$ !-omega
+!!$ fx(i,j,k)=-(4.*pi**2*psix(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fy(i,j,k)=-(4.*pi**2*psiy(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fz(i,j,k)=-(4.*pi**2*psiz(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft forward
+!!$ call rlft3(fx,sf1x,sf2x,1)
+!!$ call rlft3(fy,sf1y,sf2y,1)
+!!$ call rlft3(fz,sf1z,sf2z,1)
+!!$
+!!$
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$ !calcul de la solution dans l'espace des frequences
+!!$
+!!$ do p=1,nz
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$ do n=1,ny
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$ do m=1,nx/2
+!!$
+!!$ if ( (m-1)<=(nx/2) ) then
+!!$ kx=(m-1)/t1
+!!$ else
+!!$ kx=(m-1-nx)/t1
+!!$ end if
+!!$
+!!$
+!!$
+!!$ r2=kx**2+ky**2+kz**2
+!!$
+!!$
+!!$ su1x(m,n,p)=cmplx(0.,1.)*(ky*sf1z(m,n,p)-kz*sf1y(m,n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su1x(m,n,p)=0.
+!!$
+!!$ su1y(m,n,p)=cmplx(0.,1.)*(kz*sf1x(m,n,p)-kx*sf1z(m,n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su1y(m,n,p)=0.
+!!$
+!!$ su1z(m,n,p)=cmplx(0.,1.)*(kx*sf1y(m,n,p)-ky*sf1x(m,n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su1z(m,n,p)=0.
+!!$
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$ m=nx/2+1
+!!$ kx=(m-1)/t1
+!!$ do p=1,nz
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$ do n=1,ny
+!!$
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$
+!!$ r2=kx**2+ky**2+kz**2
+!!$
+!!$
+!!$ !poisson+vitesse
+!!$ su2x(n,p)=cmplx(0.,1.)*(ky*sf2z(n,p)-kz*sf2y(n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su2x(n,p)=0.
+!!$
+!!$ su2y(n,p)=cmplx(0.,1.)*(kz*sf2x(n,p)-kx*sf2z(n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su2y(n,p)=0.
+!!$
+!!$
+!!$ su2z(n,p)=cmplx(0.,1.)*(kx*sf2y(n,p)-ky*sf2x(n,p))/(2.*pi*r2)
+!!$ if ((r2==0)) su2z(n,p)=0.
+!!$
+!!$ !su2z(n,p)=-2.*pi*cmplx(0.,1.)*(-kx*sf2y(n,p)+ky*sf2x(n,p))/(4.*pi**2*r2)
+!!$ !if ((r2==0)) su2z(n,p)=0.
+!!$
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny*nz)
+!!$
+!!$ call rlft3(psix,su1x,su2x,-1)
+!!$ call rlft3(psiy,su1y,su2y,-1)
+!!$ call rlft3(psiz,su1z,su2z,-1)
+!!$
+!!$ psix=fac*psix
+!!$ psiy=fac*psiy
+!!$ psiz=fac*psiz
+!!$
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psix-exax)),maxloc(abs(psix-exax))
+!!$ print*,maxval(abs(psiy-exay)),maxloc(abs(psiy-exay))
+!!$ print*,maxval(abs(psiz-exaz)),maxloc(abs(psiz-exaz))
+!!$
+!!$
+!!$ deallocate (psix,exax,fx)
+!!$ deallocate (psiy,exay,fy)
+!!$ deallocate (psiz,exaz,fz)
+!!$ deallocate(sf1x,su1x)
+!!$ deallocate(sf1y,su1y)
+!!$ deallocate(sf1z,su1z)
+!!$ deallocate(sf2x,su2x)
+!!$ deallocate(sf2y,su2y)
+!!$ deallocate(sf2z,su2z)
+
+ !===============================================================
+ !test laplacien + champ de vitesse 3D: utilisation de rlft3
+ !================================================================
+
+ integer :: nx,ny,nz
+ real(kind=8),dimension(:,:,:),allocatable :: donne_init,donne_fin
+ complex(kind=8),dimension(:,:,:),allocatable :: sf1x, sf1y, sf1z
+ complex(kind=8),dimension(:,:,:),allocatable :: su1x, su1y, su1z
+ complex(kind=8),dimension(:,:),allocatable :: sf2x, sf2y, sf2z
+ complex(kind=8),dimension(:,:),allocatable :: su2x, su2y, su2z
+
+ integer :: i,j,k,m,n,p
+ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz,kx,ky,kz,r2,coeff,cpt
+ real(kind=8),dimension(:,:,:),allocatable :: psix,psiy,psiz,fx,fy,fz,exax,exay,exaz
+
+
+ nx=33
+ ny=33
+ nz=33
+
+ xg=-1.
+ xd=1.
+ yb=-1.
+ yh=1.
+ zd=-1.
+ zf=1.
+
+ t1=xd-xg
+ t2=yh-yb
+ t3=zf-zd
+
+
+ dx=t1/(nx-1)
+ dy=t2/(ny-1)
+ dz=t3/(nz-1)
+
+ nx=nx-1
+ ny=ny-1
+ nz=nz-1
+
+
+
+ allocate (psix(1:nx,1:ny,1:nz),exax(1:nx,1:ny,1:nz),fx(1:nx,1:ny,1:nz))
+ allocate (psiy(1:nx,1:ny,1:nz),exay(1:nx,1:ny,1:nz),fy(1:nx,1:ny,1:nz))
+ allocate (psiz(1:nx,1:ny,1:nz),exaz(1:nx,1:ny,1:nz),fz(1:nx,1:ny,1:nz))
+ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+
+
+
+ do k=1,nz
+ z=zd+(k-1)*dz
+ do j=1,ny
+ y=yb+(j-1)*dy
+ do i=1,nx
+ x=xg+(i-1)*dx
+
+ !psi
+ psix(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+ psiy(i,j,k)=sin(2.*pi*x/t1)*sin(2.*pi*y/t2)*sin(2.*pi*z/t3)
+ psiz(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)
+
+ !vitesse
+ exax(i,j,k)=-2.*pi*sin(2.*pi*y/t2)*(cos(2.*pi*x/t1)*sin(2.*pi*z/t3)*t3+sin(2.*pi*x/t1)*cos(2.*pi*z/t3)*t2)/(t2*t3)
+ exay(i,j,k)=-2.*pi*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)*(cos(2.*pi*x/t1)*t1-sin(2.*pi*x/t1)*t3)/(t1*t3)
+ exaz(i,j,k)=2.*pi*sin(2.*pi*y/t2)*cos(2.*pi*x/t1)*(sin(2.*pi*z/t3)*t2+cos(2.*pi*z/t3)*t1)/(t2*t1)
+
+ !-omega
+ fx(i,j,k)=-(4.*pi**2*psix(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+ fy(i,j,k)=-(4.*pi**2*psiy(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+ fz(i,j,k)=-(4.*pi**2*psiz(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+
+ end do
+ end do
+ end do
+
+
+ !fft forward
+ call rlft3(fx,sf1x,sf2x,1)
+ call rlft3(fy,sf1y,sf2y,1)
+ call rlft3(fz,sf1z,sf2z,1)
+
+
+ !frequence=0 : n=0
+ !0<f<fc : 1<=n<=N/2-1
+ !f=fc=-fc : n=N/2
+ !-fc<f<0 : N/2+1<=n<=N-1
+
+ !calcul de la solution dans l'espace des frequences
+
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/t3
+ else
+ kz=(p-1-nz)/t3
+ end if
+ do n=1,ny
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/t2
+ else
+ ky=(n-1-ny)/t2
+ end if
+ do m=1,nx/2
+
+ if ( (m-1)<=(nx/2) ) then
+ kx=(m-1)/t1
+ else
+ kx=(m-1-nx)/t1
+ end if
+
+
+
+ r2=kx**2+ky**2+kz**2
+
+
+ su1x(m,n,p)=cmplx(0.,1.)*(ky*sf1z(m,n,p)-kz*sf1y(m,n,p))/(2.*pi*r2)
+ if ((r2==0)) su1x(m,n,p)=0.
+
+ su1y(m,n,p)=cmplx(0.,1.)*(kz*sf1x(m,n,p)-kx*sf1z(m,n,p))/(2.*pi*r2)
+ if ((r2==0)) su1y(m,n,p)=0.
+
+ su1z(m,n,p)=cmplx(0.,1.)*(kx*sf1y(m,n,p)-ky*sf1x(m,n,p))/(2.*pi*r2)
+ if ((r2==0)) su1z(m,n,p)=0.
+
+
+
+ end do
+ end do
+ end do
+
+ m=nx/2+1
+ kx=(m-1)/t1
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/t3
+ else
+ kz=(p-1-nz)/t3
+ end if
+ do n=1,ny
+
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/t2
+ else
+ ky=(n-1-ny)/t2
+ end if
+
+
+ r2=kx**2+ky**2+kz**2
+
+
+ !poisson+vitesse
+ su2x(n,p)=cmplx(0.,1.)*(ky*sf2z(n,p)-kz*sf2y(n,p))/(2.*pi*r2)
+ if ((r2==0)) su2x(n,p)=0.
+
+ su2y(n,p)=cmplx(0.,1.)*(kz*sf2x(n,p)-kx*sf2z(n,p))/(2.*pi*r2)
+ if ((r2==0)) su2y(n,p)=0.
+
+
+ su2z(n,p)=cmplx(0.,1.)*(kx*sf2y(n,p)-ky*sf2x(n,p))/(2.*pi*r2)
+ if ((r2==0)) su2z(n,p)=0.
+
+ !su2z(n,p)=-2.*pi*cmplx(0.,1.)*(-kx*sf2y(n,p)+ky*sf2x(n,p))/(4.*pi**2*r2)
+ !if ((r2==0)) su2z(n,p)=0.
+
+
+
+ end do
+ end do
+
+
+ !fft backward
+ fac=2./(nx*ny*nz)
+
+ call rlft3(psix,su1x,su2x,-1)
+ call rlft3(psiy,su1y,su2y,-1)
+ call rlft3(psiz,su1z,su2z,-1)
+
+ psix=fac*psix
+ psiy=fac*psiy
+ psiz=fac*psiz
+
+
+ !exa=f
+ !erreur
+ print*,"erreur"
+ print*,maxval(abs(psix-exax)),maxloc(abs(psix-exax))
+ print*,maxval(abs(psiy-exay)),maxloc(abs(psiy-exay))
+ print*,maxval(abs(psiz-exaz)),maxloc(abs(psiz-exaz))
+
+
+ deallocate (psix,exax,fx)
+ deallocate (psiy,exay,fy)
+ deallocate (psiz,exaz,fz)
+ deallocate(sf1x,su1x)
+ deallocate(sf1y,su1y)
+ deallocate(sf1z,su1z)
+ deallocate(sf2x,su2x)
+ deallocate(sf2y,su2y)
+ deallocate(sf2z,su2z)
+
+
+
+!!$ !==========================================================================
+!!$ !test laplacien 3D: poisson ordre2 + champ de vitesse utilisation de rlft3
+!!$ !===========================================================================
+!!$
+!!$ integer(I4B) :: nx,ny,nz
+!!$ real(SP),dimension(:,:,:),allocatable :: donne_init,donne_fin
+!!$ complex(SPC),dimension(:,:,:),allocatable :: sf1x, sf1y, sf1z ,deb1
+!!$ complex(SPC),dimension(:,:,:),allocatable :: su1x, su1y, su1z
+!!$ complex(SPC),dimension(:,:),allocatable :: sf2x, sf2y, sf2z ,deb2
+!!$ complex(SPC),dimension(:,:),allocatable :: su2x, su2y, su2z
+!!$
+!!$ integer :: i,j,k,m,n,p
+!!$ real :: fac,x,y,z,xg,xd,yb,yh,zd,zf,t1,t2,t3,dx,dy,dz,kx,ky,kz,r2,coeff,ux,uy,uz
+!!$ real(SP),dimension(:,:,:),allocatable :: psix,psiy,psiz,fx,fy,fz,exax,exay,exaz
+!!$
+!!$ nx=8
+!!$ ny=8
+!!$ nz=8
+!!$
+!!$ xg=-1.
+!!$ xd=1.
+!!$ yb=-1.
+!!$ yh=1.
+!!$ zd=-1.
+!!$ zf=1.
+!!$
+!!$ t1=xd-xg
+!!$ t2=yh-yb
+!!$ t3=zf-zd
+!!$
+!!$
+!!$ dx=t1/nx
+!!$ dy=t2/ny
+!!$ dz=t3/nz
+!!$
+!!$ if ((dx/=dy).or.(dx/=dz)) then
+!!$ print*,"attention dx=dy=dz"
+!!$ stop
+!!$ end if
+!!$
+!!$ allocate (psix(1:nx,1:ny,1:nz),exax(1:nx,1:ny,1:nz),fx(1:nx,1:ny,1:nz))
+!!$ allocate (psiy(1:nx,1:ny,1:nz),exay(1:nx,1:ny,1:nz),fy(1:nx,1:ny,1:nz))
+!!$ allocate (psiz(1:nx,1:ny,1:nz),exaz(1:nx,1:ny,1:nz),fz(1:nx,1:ny,1:nz))
+!!$ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+!!$ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+!!$ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+!!$ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+!!$
+!!$ allocate (deb1(1:nx/2,1:ny,1:nz),deb2(1:ny,1:nz))
+!!$
+!!$ do k=1,nz
+!!$ z=zd+(k-1)*dz
+!!$ do j=1,ny
+!!$ y=yb+(j-1)*dy
+!!$ do i=1,nx
+!!$ x=xg+(i-1)*dx
+!!$
+!!$ !psi
+!!$ psix(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*cos(2.*pi*z/t3)
+!!$ psiy(i,j,k)=sin(2.*pi*x/t1)*sin(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$ psiz(i,j,k)=cos(2.*pi*x/t1)*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)
+!!$
+!!$ !vitesse
+!!$ exax(i,j,k)=-2.*pi*sin(2.*pi*y/t2)*(cos(2.*pi*x/t1)*sin(2.*pi*z/t3)*t3+sin(2.*pi*x/t1)*cos(2.*pi*z/t3)*t2)/(t2*t3)
+!!$ exay(i,j,k)=-2.*pi*cos(2.*pi*y/t2)*sin(2.*pi*z/t3)*(cos(2.*pi*x/t1)*t1-sin(2.*pi*x/t1)*t3)/(t1*t3)
+!!$ exaz(i,j,k)=2.*pi*sin(2.*pi*y/t2)*cos(2.*pi*x/t1)*(sin(2.*pi*z/t3)*t2+cos(2.*pi*z/t3)*t1)/(t2*t1)
+!!$
+!!$ !-omega
+!!$ fx(i,j,k)=-(4.*pi**2*psix(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fy(i,j,k)=-(4.*pi**2*psiy(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$ fz(i,j,k)=-(4.*pi**2*psiz(i,j,k)*(t2**2*t3**2+t1**2*t3**2+t1**2*t2**2))/((t1*t2*t3)**2)
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$ !fft forward
+!!$ call rlft3(fx,sf1x,sf2x,1)
+!!$ call rlft3(fy,sf1y,sf2y,1)
+!!$ call rlft3(fz,sf1z,sf2z,1)
+!!$
+!!$ call rlft3(exax,deb1,deb2,1)
+!!$
+!!$ !frequence=0 : n=0
+!!$ !0<f<fc : 1<=n<=N/2-1
+!!$ !f=fc=-fc : n=N/2
+!!$ !-fc<f<0 : N/2+1<=n<=N-1
+!!$
+!!$ !calcul de la solution dans l'espace des frequences (discretisation d'ordre2 du laplacien)
+!!$ m=nx/2+1
+!!$ kx=(m-1)/t1
+!!$ do p=1,nz
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$ do n=1,ny
+!!$
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$
+!!$ !su2x(n,p)=0.5*dx**2*sf2x(n,p)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.)
+!!$
+!!$ r2=cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.
+!!$ !r2=cos(2.*pi*kx*t1/nx)+cos(2.*pi*ky*t2/ny)+cos(2.*pi*kz*t3/nz)-3.
+!!$
+!!$ ux=0.5*dx**2*sf2x(n,p)/r2
+!!$ uy=0.5*dx**2*sf2y(n,p)/r2
+!!$ uz=0.5*dx**2*sf2z(n,p)/r2
+!!$
+!!$ su2x(n,p)=-2.*pi*cmplx(0.,1.)*(ky*uz-kz*uy)
+!!$ su2y(n,p)=-2.*pi*cmplx(0.,1.)*(kz*ux-kx*uz)
+!!$ su2z(n,p)=-2.*pi*cmplx(0.,1.)*(kx*uy-ky*ux)
+!!$
+!!$
+!!$ end do
+!!$ end do
+!!$
+!!$ do p=1,nz
+!!$ if ( (p-1)<=(nz/2) ) then
+!!$ kz=(p-1)/t3
+!!$ else
+!!$ kz=(p-1-nz)/t3
+!!$ end if
+!!$ do n=1,ny
+!!$ if ( (n-1)<=(ny/2) ) then
+!!$ ky=(n-1)/t2
+!!$ else
+!!$ ky=(n-1-ny)/t2
+!!$ end if
+!!$ do m=1,nx/2
+!!$
+!!$ if ( (m-1)<=(nx/2) ) then
+!!$ kx=(m-1)/t1
+!!$ else
+!!$ kx=(m-1-nx)/t1
+!!$ end if
+!!$ !su1x(m,n,p)=0.5*dx**2*sf1x(m,n,p)/(cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.)
+!!$ !if ((n==1).and.(m==1).and.(p==1)) su1x(m,n,p)=0.
+!!$
+!!$ r2=cos(2.*pi*(m-1)/nx)+cos(2.*pi*(n-1)/ny)+cos(2.*pi*(p-1)/nz)-3.
+!!$ !r2=cos(2.*pi*kx*t1/nx)+cos(2.*pi*ky*t2/ny)+cos(2.*pi*kz*t3/nz)-3.
+!!$
+!!$ ux=0.5*dx**2*sf1x(m,n,p)/r2
+!!$ uy=0.5*dx**2*sf1y(m,n,p)/r2
+!!$ uz=0.5*dx**2*sf1z(m,n,p)/r2
+!!$
+!!$ su1x(m,n,p)=-2.*pi*cmplx(0.,1.)*(ky*uz-kz*uy)
+!!$ su1y(m,n,p)=-2.*pi*cmplx(0.,1.)*(kz*ux-kx*uz)
+!!$ su1z(m,n,p)=-2.*pi*cmplx(0.,1.)*(kx*uy-ky*ux)
+!!$
+!!$ if(r2==0.) then
+!!$ su1x(m,n,p)=0.
+!!$ su1y(m,n,p)=0.
+!!$ su1z(m,n,p)=0.
+!!$ end if
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$
+!!$
+!!$
+!!$ !fft backward
+!!$ fac=2./(nx*ny*nz)
+!!$
+!!$ call rlft3(psix,su1x,su2x,-1)
+!!$ call rlft3(psiy,su1y,su2y,-1)
+!!$ call rlft3(psiz,su1z,su2z,-1)
+!!$
+!!$ psix=fac*psix
+!!$ psiy=fac*psiy
+!!$ psiz=fac*psiz
+!!$
+!!$
+!!$ !exa=f
+!!$ !erreur
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(psix-exax)),maxloc(abs(psix-exax))
+!!$ print*,maxval(abs(psiy-exay)),maxloc(abs(psiy-exay))
+!!$ print*,maxval(abs(psiz-exaz)),maxloc(abs(psiz-exaz))
+!!$
+!!$ print*,"dx**2",dx**2
+!!$
+!!$
+!!$
+!!$ deallocate (psix,exax,fx)
+!!$ deallocate (psiy,exay,fy)
+!!$ deallocate (psiz,exaz,fz)
+!!$ deallocate(sf1x,su1x)
+!!$ deallocate(sf1y,su1y)
+!!$ deallocate(sf1z,su1z)
+!!$ deallocate(sf2x,su2x)
+!!$ deallocate(sf2y,su2y)
+!!$ deallocate(sf2z,su2z)
+
+
+
+
+end program test_fft
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/advection_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/advection_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..88c87c21f46aff575db09ada7fc5a4c10420a7b1
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/advection_mod.f90
@@ -0,0 +1,711 @@
+module advection_mod
+ use donnees_mod
+ use tab_mod
+ use remaillage_mod
+ use interpolation_mod
+ use nrtype
+ USE nrutil
+ USE nr
+contains
+
+ subroutine def_v_advec (vitx,vity,vitz,tps)
+ implicit none
+
+ real(kind=8),intent(in) :: tps
+ real(kind=8),dimension(1:nx_gro,1:ny_gro,1:nz_gro),intent(out) :: vitx,vity,vitz
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+
+ !-------------------
+ !deformation sphere:
+ !--------------------
+ do k=1,nz_gro
+ z=zd+(k-1)*dz_gro
+ do j=1,ny_gro
+ y=yb+(j-1)*dy_gro
+ do i=1,nx_gro
+ x=xg+(i-1)*dx_gro
+
+ vitx(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z)
+ vity(i,j,k)=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)
+ vitz(i,j,k)=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2
+
+ end do
+ end do
+ end do
+
+ !----------------------------------
+ !champ turbulent
+ !----------------------------------
+
+!!$ allocate (vxgr(1:nx,1:ny,1:nz),vygr(1:nx,1:ny,1:nz),vzgr(1:nx,1:ny,1:nz))
+!!$ open(20,file='data_gh/datavelx',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((vxgr(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+!!$ close(20)
+!!$
+!!$ open(20,file='data_gh/datavely',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((vygr(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+!!$ close(20)
+!!$
+!!$ open(20,file='data_gh/datavelz',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((vzgr(i,j,k),i=1,nx_gro),j=1,nx_gro),k=1,nx_gro)
+!!$ close(20)
+!!$
+!!$ vitx=vxgr
+!!$ vity=vygr
+!!$ vitz=vzgr
+!!$ deallocate (vxgr,vygr,vzgr)
+
+
+ end subroutine def_v_advec
+
+
+ subroutine vitesse_fft
+ implicit none
+
+ complex(kind=8),dimension(:,:,:),pointer :: sf1x, sf1y, sf1z
+ complex(kind=8),dimension(:,:,:),pointer :: su1x, su1y, su1z
+ complex(kind=8),dimension(:,:),pointer :: sf2x, sf2y, sf2z
+ complex(kind=8),dimension(:,:),pointer :: su2x, su2y, su2z
+
+ integer :: i,j,k,m,n,p
+ real(kind=8) :: fac,x,y,z,l1,l2,l3,kx,ky,kz,r2,coeff
+ complex(kind=8) :: coef
+
+
+ l1=(xd-xg)
+ l2=(yh-yb)
+ l3=(zf-zd)
+
+ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+
+
+ !fft forward
+ call rlft3(omgx,sf1x,sf2x,1)
+ call rlft3(omgy,sf1y,sf2y,1)
+ call rlft3(omgz,sf1z,sf2z,1)
+
+ !frequence=0 : n=0
+ !0<f<fc : 1<=n<=N/2-1
+ !f=fc=-fc : n=N/2
+ !-fc<f<0 : N/2+1<=n<=N-1
+
+ fac=2./(nx*ny*nz) ! pour normalisation de la fft inverse
+
+ !calcul de la solution dans l'espace des frequences
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+ do m=1,nx/2
+
+ if ( (m-1)<=(nx/2) ) then
+ kx=(m-1)/l1
+ else
+ kx=(m-1-nx)/l1
+ end if
+
+
+
+ r2=kx**2+ky**2+kz**2
+ coef=-fac*cmplx(0.,1.)/(2.*pi*r2)
+
+
+ su1x(m,n,p)=coef*(ky*sf1z(m,n,p)-kz*sf1y(m,n,p))
+ if ((r2==0)) su1x(m,n,p)=0.
+
+ su1y(m,n,p)=coef*(kz*sf1x(m,n,p)-kx*sf1z(m,n,p))
+ if ((r2==0)) su1y(m,n,p)=0.
+
+ su1z(m,n,p)=coef*(kx*sf1y(m,n,p)-ky*sf1x(m,n,p))
+ if ((r2==0)) su1z(m,n,p)=0.
+
+
+
+ end do
+ end do
+ end do
+
+ m=nx/2+1
+ kx=(m-1)/l1
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+
+
+ r2=kx**2+ky**2+kz**2
+ coef=-fac*cmplx(0.,1.)/(2.*pi*r2)
+
+ !poisson+vitess
+ su2x(n,p)=coef*(ky*sf2z(n,p)-kz*sf2y(n,p))
+ su2y(n,p)=coef*(kz*sf2x(n,p)-kx*sf2z(n,p))
+ su2z(n,p)=coef*(kx*sf2y(n,p)-ky*sf2x(n,p))
+
+
+ !pour -omega et sans normalisation:
+ !---------------------------------
+ !su2z(n,p)=-2.*pi*cmplx(0.,1.)*(-kx*sf2y(n,p)+ky*sf2x(n,p))/(4.*pi**2*r2)
+ !if ((r2==0)) su2z(n,p)=0.
+
+
+
+ end do
+ end do
+
+ !fft backward
+
+ call rlft3(vxg,su1x,su2x,-1)
+ call rlft3(vyg,su1y,su2y,-1)
+ call rlft3(vzg,su1z,su2z,-1)
+
+ deallocate(sf1x,su1x)
+ deallocate(sf1y,su1y)
+ deallocate(sf1z,su1z)
+ deallocate(sf2x,su2x)
+ deallocate(sf2y,su2y)
+ deallocate(sf2z,su2z)
+
+
+ end subroutine vitesse_fft
+
+
+
+
+
+
+ subroutine vitesse_fft_uinf
+ implicit none
+
+ complex(kind=8),dimension(:,:,:),pointer :: sf1x, sf1y, sf1z
+ complex(kind=8),dimension(:,:,:),pointer :: su1x, su1y, su1z
+ complex(kind=8),dimension(:,:),pointer :: sf2x, sf2y, sf2z
+ complex(kind=8),dimension(:,:),pointer :: su2x, su2y, su2z
+
+ integer :: i,j,k,m,n,p
+ real(kind=8) :: fac,x,y,z,l1,l2,l3,kx,ky,kz,r2,coeff,uinfx,uinfy
+ complex(kind=8) :: coef
+
+
+ l1=(xd-xg)
+ l2=(yh-yb)
+ l3=(zf-zd)
+
+ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+
+
+ !fft forward
+ call rlft3(omgx,sf1x,sf2x,1)
+ call rlft3(omgy,sf1y,sf2y,1)
+ call rlft3(omgz,sf1z,sf2z,1)
+
+ !frequence=0 : n=0
+ !0<f<fc : 1<=n<=N/2-1
+ !f=fc=-fc : n=N/2
+ !-fc<f<0 : N/2+1<=n<=N-1
+
+ fac=2./(nx*ny*nz) ! pour normalisation de la fft inverse
+
+ !calcul de la solution dans l'espace des frequences
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+ do m=1,nx/2
+
+ if ( (m-1)<=(nx/2) ) then
+ kx=(m-1)/l1
+ else
+ kx=(m-1-nx)/l1
+ end if
+
+
+
+ r2=kx**2+ky**2+kz**2
+ coef=-fac*cmplx(0.,1.)/(2.*pi*r2)
+
+
+ uinfx=(4.*(1./0.4844)**2)/((yh-yb)*(zf-zd))!debit*surface domaine physique/surface du domaine numérique
+
+ !if ((time>=3.).and.(time<=4.)) then
+ ! uinfy=sin(pi*(time-3.))
+ !else
+ uinfy=0.
+ !end if
+
+
+ su1x(m,n,p)=coef*(ky*sf1z(m,n,p)-kz*sf1y(m,n,p))
+ if ((r2==0)) su1x(m,n,p)=2.*uinfx !atttention mettre 2*uinfx
+
+ su1y(m,n,p)=coef*(kz*sf1x(m,n,p)-kx*sf1z(m,n,p))
+ if ((r2==0)) su1y(m,n,p)=2.*uinfy
+
+ su1z(m,n,p)=coef*(kx*sf1y(m,n,p)-ky*sf1x(m,n,p))
+ if ((r2==0)) su1z(m,n,p)=0.
+
+
+
+ end do
+ end do
+ end do
+
+ m=nx/2+1
+ kx=(m-1)/l1
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+
+
+ r2=kx**2+ky**2+kz**2
+ coef=-fac*cmplx(0.,1.)/(2.*pi*r2)
+
+ !poisson+vitess
+ su2x(n,p)=coef*(ky*sf2z(n,p)-kz*sf2y(n,p))
+ su2y(n,p)=coef*(kz*sf2x(n,p)-kx*sf2z(n,p))
+ su2z(n,p)=coef*(kx*sf2y(n,p)-ky*sf2x(n,p))
+
+
+ !pour -omega et sans normalisation:
+ !---------------------------------
+ !su2z(n,p)=-2.*pi*cmplx(0.,1.)*(-kx*sf2y(n,p)+ky*sf2x(n,p))/(4.*pi**2*r2)
+ !if ((r2==0)) su2z(n,p)=0.
+
+
+
+ end do
+ end do
+
+ !fft backward
+
+ call rlft3(vxg,su1x,su2x,-1)
+ call rlft3(vyg,su1y,su2y,-1)
+ call rlft3(vzg,su1z,su2z,-1)
+
+ deallocate(sf1x,su1x)
+ deallocate(sf1y,su1y)
+ deallocate(sf1z,su1z)
+ deallocate(sf2x,su2x)
+ deallocate(sf2y,su2y)
+ deallocate(sf2z,su2z)
+
+
+ end subroutine vitesse_fft_uinf
+
+
+
+
+
+
+
+
+ subroutine crea_part_x
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff*maxval(sqrt(omgx**2+omgy**2+omgz**2))
+ npart=0
+ numpg=0
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ if (sqrt(omgx(i,j,k)**2+omgy(i,j,k)**2+omgz(i,j,k)**2)>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l3(vxg,x,y,z)
+ !vy(npart)=interpol_v_l3(vyg,x,y,z)
+ !vz(npart)=interpol_v_l3(vzg,x,y,z)
+ omx(npart)=omgx(i,j,k)
+ omy(npart)=omgy(i,j,k)
+ omz(npart)=omgz(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_x
+
+ subroutine crea_part_y
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff*maxval(sqrt(omgx**2+omgy**2+omgz**2))
+ npart=0
+ numpg=0
+ do k=1,nz
+ z=ztab(k)
+ do i=1,nx
+ x=xtab(i)
+ do j=1,ny
+ y=ytab(j)
+
+ if (sqrt(omgx(i,j,k)**2+omgy(i,j,k)**2+omgz(i,j,k)**2)>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l3(vxg,x,y,z)
+ !vy(npart)=interpol_v_l3(vyg,x,y,z)
+ !vz(npart)=interpol_v_l3(vzg,x,y,z)
+ omx(npart)=omgx(i,j,k)
+ omy(npart)=omgy(i,j,k)
+ omz(npart)=omgz(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_y
+
+ subroutine crea_part_z
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff*maxval(sqrt(omgx**2+omgy**2+omgz**2))
+ npart=0
+ numpg=0
+
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+ do k=1,nz
+ z=ztab(k)
+
+ if (sqrt(omgx(i,j,k)**2+omgy(i,j,k)**2+omgz(i,j,k)**2)>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ !vx(npart)=interpol_v_l3(vxg,x,y,z)
+ !vy(npart)=interpol_v_l3(vyg,x,y,z)
+ !vz(npart)=interpol_v_l3(vzg,x,y,z)
+ omx(npart)=omgx(i,j,k)
+ omy(npart)=omgy(i,j,k)
+ omz(npart)=omgz(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_z
+
+ subroutine ad_euler_x
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ xp(i)=xp(i)+dt*vx(i)
+ end do
+
+ end subroutine ad_euler_x
+
+ subroutine ad_euler_y
+ implicit none
+
+ integer :: i,j
+ real(kind=8) :: x,y
+
+ do i=1,npart
+ yp(i)=yp(i)+dt*vy(i)
+ end do
+
+ end subroutine ad_euler_y
+
+ subroutine ad_euler_z
+ implicit none
+
+ integer :: i
+
+ do i=1,npart
+ zp(i)=zp(i)+dt*vz(i)
+ end do
+
+ end subroutine ad_euler_z
+
+
+
+
+
+
+ !===============================
+ !SPLITTING
+ !calcul de la vitesse pour une advection d'euler à l'ordre 2 ou 3
+ !===============================
+
+ subroutine update_vx_2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5D0*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5D0*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5D0*dt*vz(ib)
+ end do
+ call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx)
+ deallocate(xp1,yp1,zp1)
+ end subroutine update_vx_2
+
+ subroutine update_vy_2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)-0.5D0*dt*vx(ib)
+ yp1(ib)=yp(ib)+0.5D0*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5D0*dt*vz(ib)
+ end do
+ call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy)
+ deallocate(xp1,yp1,zp1)
+ end subroutine update_vy_2
+
+ subroutine update_vz_2
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart),yp1(1:npart),zp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)-0.5D0*dt*vx(ib)
+ yp1(ib)=yp(ib)-0.5D0*dt*vy(ib)
+ zp1(ib)=zp(ib)+0.5D0*dt*vz(ib)
+ end do
+ call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz)
+ deallocate(xp1,yp1,zp1)
+ end subroutine update_vz_2
+
+
+
+ subroutine update_vx_3
+ implicit none
+ integer :: ib
+
+
+ allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp1(1:npart),zp2(1:npart))
+ allocate (vx1(1:npart),vx2(1:npart),vx3(1:npart),vx4(1:npart),vy1(1:npart),vz1(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)+2.D0*dt*vx(ib)/3.D0
+ yp1(ib)=yp(ib)+2.D0*dt*vy(ib)/3.D0
+ zp1(ib)=zp(ib)+2.D0*dt*vz(ib)/3.D0
+ end do
+
+ call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx1)
+ call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy1)
+ call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)+vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+vy1(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)+vz1(ib))
+ end do
+
+ call interpo_l3_3d(vxg,xp2,yp,zp,vx2)
+ call interpo_l3_3d(vxg,xp,yp2,zp,vx3)
+ call interpo_l3_3d(vxg,xp,yp,zp2,vx4)
+
+ do ib=1,npart
+ vx(ib)=-0.5D0*vx(ib)+3.D0*vx1(ib)/4.D0+vx2(ib)/4.D0+vx3(ib)/4.D0+vx4(ib)/4.D0
+ end do
+
+ deallocate (xp1,xp2,yp1,yp2,zp1,zp2)
+ deallocate (vx1,vx2,vx3,vx4,vy1,vz1)
+
+
+ end subroutine update_vx_3
+
+ subroutine update_vy_3
+ implicit none
+ integer :: ib,i,j
+
+ allocate (xp0(1:npart),xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp1(1:npart),zp2(1:npart))
+ allocate (vx1(1:npart),vz1(1:npart),vy1(1:npart),vy2(1:npart),vy3(1:npart),vy4(1:npart),vy5(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)-dt*vx(ib)/3.D0
+ yp1(ib)=yp(ib)+2.D0*dt*vy(ib)/3.D0
+ zp1(ib)=zp(ib)+2.D0*dt*vz(ib)/3.D0
+ xp0(ib)=xp(ib)-4.D0*dt*vx(ib)/3.D0
+ end do
+
+ call interpo_l3_3d(vxg1,xp1,yp1,zp1,vx1)
+ call interpo_l3_3d(vyg1,xp1,yp1,zp1,vy1)
+ call interpo_l3_3d(vyg1,xp0,yp1,zp1,vy2)
+ call interpo_l3_3d(vzg1,xp0,yp1,zp1,vz1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(vx(ib)-2.D0*vx1(ib))
+ yp2(ib)=yp(ib)+dt*(-vy(ib)+vy2(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)/4.D0+vz1(ib)/4.D0)
+ end do
+
+ call interpo_l3_3d(vyg,xp2,yp,zp,vy3)
+ call interpo_l3_3d(vyg,xp,yp2,zp,vy4)
+ call interpo_l3_3d(vyg,xp,yp,zp2,vy5)
+
+ do ib=1,npart
+ vy(ib)=-5.D0*vy(ib)/4.D0+3.D0*vy1(ib)/4.D0+vy3(ib)/4.D0+vy4(ib)/4.D0+vy5(ib)
+ end do
+
+
+ deallocate (xp0,xp1,xp2,yp1,yp2,zp1,zp2)
+ deallocate (vx1,vz1,vy1,vy2,vy3,vy4,vy5)
+
+ end subroutine update_vy_3
+
+ subroutine update_vz_3
+ implicit none
+ integer :: ib,i,j,k
+
+ allocate (xp1(1:npart),xp2(1:npart),yp1(1:npart),yp2(1:npart),zp0(1:npart),zp1(1:npart),zp2(1:npart))
+ allocate (vx1(1:npart),vy1(1:npart),vz1(1:npart),vz2(1:npart),vz3(1:npart),vz4(1:npart))
+
+ do ib=1,npart
+ xp1(ib)=xp(ib)-2.D0*dt*vx(ib)/3.D0
+ yp1(ib)=yp(ib)-2.D0*dt*vy(ib)/3.D0
+ zp1(ib)=zp(ib)+dt*vz(ib)/3.D0
+ zp0(ib)=zp(ib)+4.D0*dt*vz(ib)/3.D0
+ end do
+
+ call interpo_l3_3d(vzg1,xp1,yp1,zp1,vz1)
+ call interpo_l3_3d(vxg2,xp1,yp1,zp0,vx1)
+ call interpo_l3_3d(vyg2,xp1,yp1,zp0,vy1)
+
+ do ib=1,npart
+ xp2(ib)=xp(ib)+dt*(-vx(ib)+vx1(ib))
+ yp2(ib)=yp(ib)+dt*(vy(ib)-vy1(ib))
+ zp2(ib)=zp(ib)+dt*(-vz(ib)+2.D0*vz1(ib))
+ end do
+
+ call interpo_l3_3d(vzg,xp2,yp,zp,vz2)
+ call interpo_l3_3d(vzg,xp,yp2,zp,vz3)
+ call interpo_l3_3d(vzg3,xp,yp,zp2,vz4)
+
+ do ib=1,npart
+ vz(ib)=3.D0*vz1(ib)/4.D0-vz2(ib)/4.D0+vz3(ib)/4.D0+vz4(ib)/4.D0
+ end do
+
+
+ deallocate (xp1,xp2,yp1,yp2,zp0,zp1,zp2)
+ deallocate (vx1,vy1,vz1,vz2,vz3,vz4)
+
+ end subroutine update_vz_3
+
+
+ !==================================
+ !STRANG
+ !==================================
+
+ subroutine update_vx_strang
+ implicit none
+ integer :: ib
+
+ allocate (xp1(1:npart))
+ do ib=1,npart
+ xp1(ib)=xp(ib)+0.5D0*dt*vx(ib)
+ end do
+ call interpo_l3_3d(vxg1,xp1,yp,zp,vx)
+ deallocate(xp1)
+ end subroutine update_vx_strang
+
+ subroutine update_vy_strang
+ implicit none
+ integer :: ib
+
+ allocate (yp1(1:npart))
+ do ib=1,npart
+ yp1(ib)=yp(ib)+0.5D0*dt*vy(ib)
+ end do
+ call interpo_l3_3d(vyg1,xp,yp1,zp,vy)
+ deallocate(yp1)
+ end subroutine update_vy_strang
+
+ subroutine update_vz_strang
+ implicit none
+ integer :: ib
+
+ allocate (zp1(1:npart))
+ do ib=1,npart
+ zp1(ib)=zp(ib)+0.5D0*dt*vz(ib)
+ end do
+ call interpo_l3_3d(vzg1,xp,yp,zp1,vz)
+ deallocate(zp1)
+ end subroutine update_vz_strang
+
+
+
+
+
+
+end module advection_mod
+
+
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/donnees_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/donnees_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..00b50ba657e95aa17911988a9edc632b59edd22d
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/donnees_mod.f90
@@ -0,0 +1,12 @@
+module donnees_mod
+
+ integer :: nx,ny,nz,nx_gro,ny_gro,nz_gro,npg,npart,ideb,ind_drag
+ integer :: kx,ky,kz,type_b,long_bloc,cpt_ite,nite_vtk,num_suite,sauv_cpt_ite
+ real(kind=8) :: time,dx,dy,dz,dx_gro,dy_gro,dz_gro,xg,xd,yb,yh,zd,zf,dt,tfin,cfl
+ real(kind=8) :: xdeb,cutoff,dt_sauv,lambda_flu,lambda_sol,lambda_por,pi,nu
+ real(kind=8) :: ix_2old,ix_old,ix_lift_2old,ix_lift_old
+ character(len=70) :: nom_fich_vtk,nom_fich_omg_nite,nom_fich_vit_nite,nom_fich_drag,nom_fich_coupev,name_relance
+ character(len=70) :: nom_fich_chi,nom_fich_lambda
+
+
+end module donnees_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/drag_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/drag_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..60a00d4f9daf9cc555a997df281fd64edb9098a5
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/drag_mod.f90
@@ -0,0 +1,279 @@
+module drag_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+ function cd(f,u,d)
+ implicit none
+ real(kind=8),intent(in) :: f,u,d
+ real(kind=8) :: cd
+ !calcul du coeff de traine
+ !f=force scalaire x
+ !d=diametre (surface projette)
+ !u vitesse a l'infini
+ cd=2.*f/(u*u*d)
+ end function cd
+
+ function cl(f,u,d)
+ implicit none
+ real(kind=8),intent(in) :: f,u,d
+ real(kind=8) :: cl
+ !calcul du coeff de portance
+ !f=force scalaire x
+ !d=diametre (surface projette)
+ !u vitesse a l'infini
+ cl=2.*f/(u*u*d)
+ end function cl
+
+
+
+
+
+
+
+
+
+
+
+
+
+!====================================
+!methode de l'impulsion
+!=====================================
+
+ function ix()
+ implicit none
+ real(kind=8) :: ix
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,dvx,dvy,dvz
+ ix=0.
+ do i=1,nx
+ if ((i==1).or.(i==nx)) then
+ dvx=0.5*dx
+ else
+ dvx=dx
+ end if
+ do j=1,ny
+ if ((j==1).or.(j==ny)) then
+ dvy=0.5*dy
+ else
+ dvy=dy
+ end if
+ y=yb+(j-1)*dy
+ do k=1,nz
+ if ((k==1).or.(k==nz)) then
+ dvz=0.5*dz
+ else
+ dvz=dz
+ end if
+ z=zd+(k-1)*dz
+
+ ix =ix-0.5*(y*omgz(i,j,k)-z*omgy(i,j,k))*dvx*dvy*dvz
+ end do
+ end do
+ end do
+
+ end function ix
+
+ function drag_tps()
+ implicit none
+
+ real(kind=8) :: drag_tps
+ real(kind=8) :: f,ix_new
+ real(kind=8) :: rayon,uinf
+
+ rayon=0.5
+ uinf=1.
+
+ !calcul du drag coeff pour t= time-dt
+ if(ind_drag==1)then
+ ix_2old=ix()
+ drag_tps=0.
+ else
+ if (ind_drag==2) then
+ ix_old=ix()
+ drag_tps=0.
+ else
+ ix_new=ix()
+ f=(ix_new-ix_2old)/(2.*dt)
+ ix_2old=ix_old
+ ix_old=ix_new
+ drag_tps=cd(f,uinf,2.*rayon)
+
+ end if
+ end if
+
+ end function drag_tps
+
+
+ function ix_lift()result(ix)
+ implicit none
+ real(kind=8) :: ix
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,dvx,dvy,dvz
+ ix=0.
+ do i=1,nx
+ x=xg+(i-1)*dx
+ if ((i==1).or.(i==nx)) then
+ dvx=0.5*dx
+ else
+ dvx=dx
+ end if
+ do j=1,ny
+ if ((j==1).or.(j==ny)) then
+ dvy=0.5*dy
+ else
+ dvy=dy
+ end if
+ do k=1,nz
+ if ((k==1).or.(k==nz)) then
+ dvz=0.5*dz
+ else
+ dvz=dz
+ end if
+ z=zd+(k-1)*dz
+
+ ix =ix-0.5*(z*omgx(i,j,k)-x*omgz(i,j,k))*dvx*dvy*dvz
+ end do
+ end do
+ end do
+
+ end function ix_lift
+
+ function lift_tps()
+ implicit none
+
+ real(kind=8) :: lift_tps
+ real(kind=8) :: f,ix_lift_new
+ real(kind=8) :: rayon,uinf
+
+ rayon=0.5
+ uinf=1.
+
+ !calcul du lift coeff pour t= time-dt
+ if(ind_drag==1)then
+ ix_lift_2old=ix_lift()
+ lift_tps=0.
+ else
+ if (ind_drag==2) then
+ ix_lift_old=ix_lift()
+ lift_tps=0.
+ else
+ ix_lift_new=ix_lift()
+ f=(ix_lift_new-ix_lift_2old)/(2.*dt)
+ ix_lift_2old=ix_lift_old
+ ix_lift_old=ix_lift_new
+ lift_tps=cl(f,uinf,2.*rayon)
+
+ end if
+ end if
+
+ end function lift_tps
+
+
+
+
+
+
+
+ !========================================
+ !methode de l'écoulement poreux
+ !===========================================
+
+ function drag_poreux() result(drag_po)
+ implicit none
+ real(kind=8) :: drag_po
+ integer :: i,j,k
+ real(kind=8) :: dvx,dvy,dvz
+ real(kind=8) :: rayon,uinf
+
+ rayon=0.5
+ uinf=1.
+
+
+ drag_po=0.
+
+
+ do i=1,nx
+ if ((i==1).or.(i==nx)) then
+ dvx=0.5*dx
+ else
+ dvx=dx
+ end if
+ do j=1,ny
+ if ((j==1).or.(j==ny)) then
+ dvy=0.5*dy
+ else
+ dvy=dy
+ end if
+ do k=1,nz
+ if ((k==1).or.(k==nz)) then
+ dvz=0.5*dz
+ else
+ dvz=dz
+ end if
+ drag_po =drag_po+lambda(i,j,k)*chi_sphere(i,j,k)*vxg(i,j,k)*dvx*dvy*dvz
+ end do
+ end do
+ end do
+
+
+ drag_po=cd(drag_po,uinf,2.*rayon)
+
+ end function drag_poreux
+
+ function lift_poreux() result(lift_po)
+ implicit none
+ real(kind=8) :: lift_po
+ integer :: i,j,k
+ real(kind=8) :: dvx,dvy,dvz
+ real(kind=8) :: rayon,uinf
+
+ rayon=0.5
+ uinf=1.
+
+
+ lift_po=0.
+
+
+ do i=1,nx
+ if ((i==1).or.(i==nx)) then
+ dvx=0.5*dx
+ else
+ dvx=dx
+ end if
+ do j=1,ny
+ if ((j==1).or.(j==ny)) then
+ dvy=0.5*dy
+ else
+ dvy=dy
+ end if
+ do k=1,nz
+ if ((k==1).or.(k==nz)) then
+ dvz=0.5*dz
+ else
+ dvz=dz
+ end if
+ lift_po =lift_po+lambda(i,j,k)*chi_sphere(i,j,k)*vyg(i,j,k)*dvx*dvy*dvz
+ end do
+ end do
+ end do
+
+
+ lift_po=cd(lift_po,uinf,2.*rayon)
+
+ end function lift_poreux
+
+
+
+
+
+
+
+
+
+
+
+end module drag_mod
+
+
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/four2.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/four2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a7a86c8044d51bcec35486392026ff6f151cb470
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/four2.f90
@@ -0,0 +1,12 @@
+ SUBROUTINE four2(data,isign)
+ USE nrtype
+ USE nr, ONLY : fourrow
+ IMPLICIT NONE
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ COMPLEX(SPC), DIMENSION(size(data,2),size(data,1)) :: temp
+ call fourrow(data,isign)
+ temp=transpose(data)
+ call fourrow(temp,isign)
+ data=transpose(temp)
+ END SUBROUTINE four2
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/four3.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/four3.f90
new file mode 100644
index 0000000000000000000000000000000000000000..58197a672d074315486d51a7092076cb663381ad
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/four3.f90
@@ -0,0 +1,19 @@
+SUBROUTINE four3(data,isign)
+ USE nrtype
+ USE nr, ONLY : fourrow_3d
+ IMPLICIT NONE
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ COMPLEX(SPC), DIMENSION(:,:,:), ALLOCATABLE :: dat2,dat3
+
+ call fourrow_3d(data,isign)
+ allocate(dat2(size(data,2),size(data,3),size(data,1)))
+ dat2=reshape(data,shape=shape(dat2),order=(/3,1,2/))
+ call fourrow_3d(dat2,isign)
+ allocate(dat3(size(data,3),size(data,1),size(data,2)))
+ dat3=reshape(dat2,shape=shape(dat3),order=(/3,1,2/))
+ deallocate(dat2)
+ call fourrow_3d(dat3,isign)
+ data=reshape(dat3,shape=shape(data),order=(/3,1,2/))
+ deallocate(dat3)
+END SUBROUTINE four3
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d51895841910015ce59898eea1ccfdda8be81bbb
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow.f90
@@ -0,0 +1,89 @@
+ SUBROUTINE fourrow_sp(data,isign)
+ USE nrtype; USE nrutil, ONLY : assert,swap
+ IMPLICIT NONE
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
+ REAL(DP) :: theta
+ COMPLEX(SPC), DIMENSION(size(data,1)) :: temp
+ COMPLEX(DPC) :: w,wp
+ COMPLEX(SPC) :: ws
+ n=size(data,2)
+ call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_sp')
+ n2=n/2
+ j=n2
+ do i=1,n-2
+ if (j > i) call swap(data(:,j+1),data(:,i+1))
+ m=n2
+ do
+ if (m < 2 .or. j < m) exit
+ j=j-m
+ m=m/2
+ end do
+ j=j+m
+ end do
+ mmax=1
+ do
+ if (n <= mmax) exit
+ istep=2*mmax
+ theta=PI_D/(isign*mmax)
+ wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
+ w=cmplx(1.0_dp,0.0_dp,kind=dpc)
+ do m=1,mmax
+ ws=w
+ do i=m,n,istep
+ j=i+mmax
+ temp=ws*data(:,j)
+ data(:,j)=data(:,i)-temp
+ data(:,i)=data(:,i)+temp
+ end do
+ w=w*wp+w
+ end do
+ mmax=istep
+ end do
+ END SUBROUTINE fourrow_sp
+
+ SUBROUTINE fourrow_dp(data,isign)
+ USE nrtype; USE nrutil, ONLY : assert,swap
+ IMPLICIT NONE
+ COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
+ REAL(DP) :: theta
+ COMPLEX(DPC), DIMENSION(size(data,1)) :: temp
+ COMPLEX(DPC) :: w,wp
+ COMPLEX(DPC) :: ws
+ n=size(data,2)
+ call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_dp')
+ n2=n/2
+ j=n2
+ do i=1,n-2
+ if (j > i) call swap(data(:,j+1),data(:,i+1))
+ m=n2
+ do
+ if (m < 2 .or. j < m) exit
+ j=j-m
+ m=m/2
+ end do
+ j=j+m
+ end do
+ mmax=1
+ do
+ if (n <= mmax) exit
+ istep=2*mmax
+ theta=PI_D/(isign*mmax)
+ wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
+ w=cmplx(1.0_dp,0.0_dp,kind=dpc)
+ do m=1,mmax
+ ws=w
+ do i=m,n,istep
+ j=i+mmax
+ temp=ws*data(:,j)
+ data(:,j)=data(:,i)-temp
+ data(:,i)=data(:,i)+temp
+ end do
+ w=w*wp+w
+ end do
+ mmax=istep
+ end do
+ END SUBROUTINE fourrow_dp
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow_3d.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow_3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0dde413d49c2a3f078021585484dd7428d85aaa2
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/fourrow_3d.f90
@@ -0,0 +1,44 @@
+ SUBROUTINE fourrow_3d(data,isign)
+ USE nrtype; USE nrutil, ONLY : assert,swap
+ IMPLICIT NONE
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
+ REAL(DP) :: theta
+ COMPLEX(SPC), DIMENSION(size(data,1),size(data,2)) :: temp
+ COMPLEX(DPC) :: w,wp
+ COMPLEX(SPC) :: ws
+ n=size(data,3)
+ call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_3d')
+ n2=n/2
+ j=n2
+ do i=1,n-2
+ if (j > i) call swap(data(:,:,j+1),data(:,:,i+1))
+ m=n2
+ do
+ if (m < 2 .or. j < m) exit
+ j=j-m
+ m=m/2
+ end do
+ j=j+m
+ end do
+ mmax=1
+ do
+ if (n <= mmax) exit
+ istep=2*mmax
+ theta=PI_D/(isign*mmax)
+ wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
+ w=cmplx(1.0_dp,0.0_dp,kind=dpc)
+ do m=1,mmax
+ ws=w
+ do i=m,n,istep
+ j=i+mmax
+ temp=ws*data(:,:,j)
+ data(:,:,j)=data(:,:,i)-temp
+ data(:,:,i)=data(:,:,i)+temp
+ end do
+ w=w*wp+w
+ end do
+ mmax=istep
+ end do
+ END SUBROUTINE fourrow_3d
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/init_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/init_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f04a9dd77f1326728a17dc62b53f34c309f19e9b
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/init_mod.f90
@@ -0,0 +1,179 @@
+module init_mod
+ !
+ !initialisation des valeurs sur la grille
+ !
+contains
+ subroutine init_grille
+ use donnees_mod
+ use tab_mod
+ implicit none
+ integer :: i,j,k,i_tmp
+ real(kind=8) :: x,y,z, ct,t2
+ real :: romgx,romgy,romgz,r_tmp
+ character(len=70):: text_tmp
+
+
+ !---------------
+ ! 0
+ !---------------
+!!$ omgx=0.
+!!$ omgy=0.
+!!$ omgz=0.
+ !-------------------------
+ ! test poiseuille
+ !--------------------------
+
+!!$
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ omgx(i,j,k)=0.
+!!$ omgy(i,j,k)=0.
+!!$ if ( (z.ge.-1.).and.(z.le.1.)) then
+!!$ omgy(i,j,k)=-3.*z/(4.*0.5*(yh-yb))
+!!$ else
+!!$ omgy(i,j,k)=0.
+!!$ end if
+!!$ omgz(i,j,k)=0.
+!!$ end do
+!!$ end do
+!!$ end do
+
+ !---------------------------------
+ ! test poiseuille/sphere
+ !--------------------------------
+
+ do k=1,nz
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ omgx(i,j,k)=0.
+ omgy(i,j,k)=0.
+ omgz(i,j,k)=0.
+ if ( (y.ge.-(1./0.4844)).and.(y.le.(1./0.4844))) then
+ omgz(i,j,k)=3.*y/((1./0.4844)**2)
+ end if
+ end do
+ end do
+ end do
+
+!!$
+!!$
+!!$ !---------------
+!!$ ! 1
+!!$ !---------------
+!!$ omgx=1.
+!!$ omgy=1.
+!!$ omgz=1.
+
+!!$ !---------------
+!!$ !test analytique
+!!$ !---------------
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ y=ytab(j)
+!!$ do i=1,nx
+!!$ x=xtab(i)
+!!$
+!!$ !ct=cos(pi*time)
+!!$ ct=1.D0
+!!$
+!!$ omgx(i,j,k)=-2.*pi*sin(2.*pi*x)*cos(2.*pi*y)*sin(pi*z)**2*ct &
+!!$ +2.*pi*sin(2.*pi*x)*sin(pi*y)**2*cos(2.*pi*z)*ct
+!!$ omgy(i,j,k)=4.*pi*sin(pi*x)**2*sin(2.*pi*y)*cos(2.*pi*z)*ct &
+!!$ +2.*pi*cos(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2*ct
+!!$ omgz(i,j,k)=-2.*pi*cos(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)*ct&
+!!$ -4.*pi*sin(pi*x)**2*cos(2.*pi*y)*sin(2.*pi*z)*ct
+!!$
+!!$ ! omgx(i,j,k)=1.
+!!$ ! omgy(i,j,k)=0.
+!!$ ! omgz(i,j,k)=0.
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+
+
+!!$ !----------------------------
+!!$ !vorticite turbulente de GH
+!!$ !-----------------------------
+!!$
+!!$ allocate (omgxr(1:nx,1:ny,1:nz),omgyr(1:nx,1:ny,1:nz),omgzr(1:nx,1:ny,1:nz))
+!!$
+!!$ open(20,file='data_gh/datax',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((omgxr(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+!!$ close(20)
+!!$
+!!$ open(20,file='data_gh/datay',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((omgyr(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+!!$ close(20)
+!!$
+!!$ open(20,file='data_gh/dataz',form='unformatted',convert='big_endian',status='unknown')
+!!$ read(20) (((omgzr(i,j,k),i=1,nx),j=1,ny),k=1,nz)
+!!$ close(20)
+!!$
+!!$ omgx=omgxr
+!!$ omgy=omgyr
+!!$ omgz=omgzr
+!!$
+!!$ deallocate (omgxr,omgyr,omgzr)
+
+
+
+!!$ if (num_suite==1) then
+!!$ open(unit=25,file=trim(name_relance),form="formatted")
+!!$
+!!$ read(25,'(A26)')text_tmp
+!!$ read(25,'(A7)')text_tmp
+!!$ read(25,'(A5)')text_tmp
+!!$ read(25,'(A25)')text_tmp
+!!$ read(25,'(A10,3(i4,1x))')text_tmp,i_tmp,i_tmp,i_tmp
+!!$ read(25,'(a6,3(f10.5))')text_tmp,r_tmp,r_tmp,r_tmp
+!!$ read(25,'(A7,3(f10.5))')text_tmp,r_tmp,r_tmp,r_tmp
+!!$
+!!$
+!!$ read(25,'(A10,i10)') text_tmp,i_tmp
+!!$ read(25,'(A21)') text_tmp
+!!$
+!!$ do k=1,nz
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ read(25,'(3(f20.9))') romgx,romgy,romgz
+!!$ omgx(i,j,k)=romgx
+!!$ omgy(i,j,k)=romgy
+!!$ omgz(i,j,k)=romgz
+!!$ end do
+!!$ end do
+!!$ end do
+!!$ close(25)
+!!$ end if
+
+
+
+
+
+
+!!$
+!!$ do k=1,nz
+!!$ do j=1,ny
+!!$ do i=1,nx
+!!$ write(11,'(3(f20.9))') real(omgx(i,j,k)),real(omgy(i,j,k)),real(omgz(i,j,k))
+!!$ end do
+!!$ end do
+!!$ end do
+
+
+
+
+
+
+
+
+
+ end subroutine init_grille
+
+
+
+end module init_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/interpolation_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/interpolation_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e2f00c7ec19ce325210ceb9df210aa1c75fa3b03
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/interpolation_mod.f90
@@ -0,0 +1,365 @@
+module interpolation_mod
+ use donnees_mod
+ contains
+
+ subroutine interpo_l3_3d(tab_grille,posx,posy,posz,tab_part)
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_grille
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:npart),intent(out) :: tab_part
+ integer :: i,c,d,e,ib,jb
+ integer,dimension(0:3) :: ip,jp,kp
+ real(kind=8),dimension(0:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1
+
+ tab_part(1:npart)=0.
+
+ !interpole en 2d la vorticite sur la grille en fonction de la position des particules et de leur vorticité
+ !---------------------------------------------------------------------------------------------------------
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(1) = floor((posx(i)-xg)/dx_gro)
+ ip(0) = ip(1) - 1
+ ip(2) = ip(1) + 1
+ ip(3) = ip(1) + 2
+
+ jp(1) = floor((posy(i)-yb)/dy_gro)
+ jp(0) = jp(1) - 1
+ jp(2) = jp(1) + 1
+ jp(3) = jp(1) + 2
+
+ kp(1) = floor((posz(i)-zd)/dz_gro)
+ kp(0) = kp(1) - 1
+ kp(2) = kp(1) + 1
+ kp(3) = kp(1) + 2
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(1),kind=8)*dx_gro-xg)/dx_gro
+ yy1 = (posy(i) - real(jp(1),kind=8)*dy_gro-yb)/dy_gro
+ zz1 = (posz(i) - real(kp(1),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=0,3
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ poidx(0)=-1./6.*xx1*(xx1-1.)*(xx1-2.)
+ poidx(1)=0.5*(1.-xx1)*(1.+xx1)*(2.-xx1)
+ poidx(2)=-0.5*xx1*(xx1+1.)*(xx1-2.)
+ poidx(3)=1/6.*xx1*(1.+xx1)*(xx1-1.)
+
+ poidy(0)=-1./6.*yy1*(yy1-1.)*(yy1-2.)
+ poidy(1)=0.5*(1.-yy1)*(1.+yy1)*(2.-yy1)
+ poidy(2)=-0.5*yy1*(yy1+1.)*(yy1-2.)
+ poidy(3)=1/6.*yy1*(1.+yy1)*(yy1-1.)
+
+ poidz(0)=-1./6.*zz1*(zz1-1.)*(zz1-2.)
+ poidz(1)=0.5*(1.-zz1)*(1.+zz1)*(2.-zz1)
+ poidz(2)=-0.5*zz1*(zz1+1.)*(zz1-2.)
+ poidz(3)=1/6.*zz1*(1.+zz1)*(zz1-1.)
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,3
+ do d=0,3
+ do c=0,3
+ tab_part(i)=tab_part(i)+tab_grille(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine interpo_l3_3d
+
+
+
+
+
+
+
+ !===========================================================================
+ !pour interpoler le champ de vitesse de la grille grossiere à la grille fine
+ !===========================================================================
+
+
+ function interpol_v_l1(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(0:1) :: ip,jp,kp
+ real(kind=8),dimension(0:1) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(1) = ip(0)+1
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(1) = jp(0)+1
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(1) = kp(0)+1
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=0,1
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=0,1
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=0,1
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(0)=1.-xx
+ poidx(1)=xx
+
+ poidy(0)=1.-yy
+ poidy(1)=yy
+
+ poidz(0)=1.-zz
+ poidz(1)=zz
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,1
+ do c=0,1
+ do d=0,1
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l1
+
+ function interpol_v_l3(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(-1:2) :: ip,jp,kp
+ real(kind=8),dimension(-1:2) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(-1) = kp(0)-1
+ kp(1) = kp(0)+1
+ kp(2) = kp(0)+2
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-1,2
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-1,2
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=-1,2
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ poidx(-1)=-1./6.*xx*(xx-1.)*(xx-2.)
+ poidx(0)=0.5*(1.-xx)*(1.+xx)*(2.-xx)
+ poidx(1)=-0.5*xx*(xx+1.)*(xx-2.)
+ poidx(2)=1/6.*xx*(1.+xx)*(xx-1.)
+
+ poidy(-1)=-1./6.*yy*(yy-1.)*(yy-2.)
+ poidy(0)=0.5*(1.-yy)*(1.+yy)*(2.-yy)
+ poidy(1)=-0.5*yy*(yy+1.)*(yy-2.)
+ poidy(2)=1/6.*yy*(1.+yy)*(yy-1.)
+
+ poidz(-1)=-1./6.*zz*(zz-1.)*(zz-2.)
+ poidz(0)=0.5*(1.-zz)*(1.+zz)*(2.-zz)
+ poidz(1)=-0.5*zz*(zz+1.)*(zz-2.)
+ poidz(2)=1/6.*zz*(1.+zz)*(zz-1.)
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-1,2
+ do c=-1,2
+ do d=-1,2
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidy(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l3
+
+ function interpol_v_l5(tab_gro,posx,posy,posz) result (v)
+ use tab_mod
+ implicit none
+
+ real(kind=8),dimension(:,:,:),intent(in) :: tab_gro
+ real(kind=8),intent(in) :: posx,posy,posz
+ real(kind=8) :: v
+ integer,dimension(-2:3) :: ip,jp,kp
+ real(kind=8),dimension(-2:3) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+ integer :: c,d,e
+ real(kind=8) :: x2,x3,x4,x5,y2,y3,y4,y5
+
+ v=0.
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx-xg)/dx_gro) !de 0 Ã nx_gro -1
+ ip(-2) = ip(0)-2
+ ip(-1) = ip(0)-1
+ ip(1) = ip(0)+1
+ ip(2) = ip(0)+2
+ ip(3) = ip(0)+3
+
+ jp(0) = floor((posy-yb)/dy_gro)
+ jp(-2) = jp(0)-2
+ jp(-1) = jp(0)-1
+ jp(1) = jp(0)+1
+ jp(2) = jp(0)+2
+ jp(3) = jp(0)+3
+
+ kp(0) = floor((posz-zd)/dz_gro)
+ kp(-2) = kp(0)-2
+ kp(-1) = kp(0)-1
+ kp(1) = kp(0)+1
+ kp(2) = kp(0)+2
+ kp(3) = kp(0)+3
+
+
+ !distance de la particule à remailler au premier point gauche
+ !-----------------------------------------------------------
+ xx = (posx - real(ip(0),kind=8)*dx_gro-xg)/dx_gro
+ yy = (posy - real(jp(0),kind=8)*dy_gro-yb)/dy_gro
+ zz = (posz - real(kp(0),kind=8)*dz_gro-zd)/dz_gro
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,3
+ ip(c)=mod(ip(c)+nx_gro,nx_gro)
+ end do
+
+ do c=-2,3
+ jp(c)=mod(jp(c)+ny_gro,ny_gro)
+ end do
+
+ do c=-2,3
+ kp(c)=mod(kp(c)+nz_gro,nz_gro)
+ end do
+
+ !calcul des poids
+ !----------------
+ x2=xx**2
+ x3=xx**3
+ x4=xx**4
+ x5=xx**5
+ y2=yy**2
+ y3=yy**3
+ y4=yy**4
+ y5=yy**5
+
+ poidx(-2)=xx/20.-x2/24.-x3/24.+x4/24.-x5/120.
+ poidx(-1)=-xx/2.+2.*x2/3.-x3/24.-x4/6.+x5/24.
+ poidx(0)=1.-xx/3.-5*x2/4.+5.*x3/12.+x4/4.-x5/12.
+ poidx(1)=xx+2.*x2/3.-7.*x3/12.-x4/6.+x5/12.
+ poidx(2)=-xx/4.-x2/24.+7.*x3/24.+x4/24.-x5/24.
+ poidx(3)=xx/30.-x3/24.+x5/120.
+
+ poidy(-2)=yy/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidy(-1)=-yy/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidy(0)=1.-yy/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidy(1)=yy+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidy(2)=-yy/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidy(3)=yy/30.-y3/24.+y5/120.
+
+ poidz(-2)=zz/20.-y2/24.-y3/24.+y4/24.-y5/120.
+ poidz(-1)=-zz/2.+2.*y2/3.-y3/24.-y4/6.+y5/24.
+ poidz(0)=1.-zz/3.-5*y2/4.+5.*y3/12.+y4/4.-y5/12.
+ poidz(1)=zz+2.*y2/3.-7.*y3/12.-y4/6.+y5/12.
+ poidz(2)=-zz/4.-y2/24.+7.*y3/24.+y4/24.-y5/24.
+ poidz(3)=zz/30.-y3/24.+y5/120.
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-2,3
+ do c=-2,3
+ do d=-2,3
+ v=v+tab_gro(ip(c)+1,jp(d)+1,kp(e)+1)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+
+ end function interpol_v_l5
+
+
+
+
+ end module interpolation_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/main.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5506bf9d84b3684a93756e28b9f614a11520c62b
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/main.f90
@@ -0,0 +1,568 @@
+program NS
+ !--------------------------------------------------------------------------
+ !resolution Navier Stokes + penalisation en periodoque
+ !
+ !--------------------------------------------------------------------------
+ use donnees_mod ! donnees
+ use tab_mod ! donnees dans tableaux
+ use init_mod ! init_grille
+ use advection_mod ! crea_part,advection
+ use remaillage_mod ! remaill_4m_centre (formules de remaillage)
+ use interpolation_mod ! formules d'interpolation (pour range kutta)
+ use resultats_mod ! res_grille_tps,res_grille_freq
+ use utile_mod
+ use penal_mod
+ use source_mod ! diffusion + strech (+ penal)
+ use drag_mod !calcul drag/lift
+ use old_mod ! ancien algo
+
+ real(kind=8) :: x,y,z
+ integer :: n ,indi1,indi2,indj,indk
+ real(kind=8) :: time1,time2,time3,time4,maxv,dragi,dragp,lifti,liftp
+
+ !pour test
+ integer :: c,i,j,ib,jb,k,cpt,nx_boucle
+ real(kind=8) :: t1,t2,t3,t4,t5,t6,t7,t8,t9,tmp,dt_boucle,r,grad,div,vexa,omexa
+ real(kind=8),dimension(1:3) :: pen
+
+ !lecture données
+ !---------------
+ open(unit=10,file="parameter",form="formatted")
+ read(10,*) xg,xd,yb,yh,zd,zf
+ read(10,*) nx,ny,nz
+ read(10,*) tfin
+ read(10,*) cutoff
+ read(10,*) type_b
+ read(10,*) long_bloc
+ read(10,*) nom_fich_vtk
+ read(10,*) lambda_flu,lambda_sol,lambda_por
+ read(10,*) nu
+ read(10,*) nom_fich_omg_nite,nom_fich_vit_nite,nom_fich_chi,nom_fich_lambda,nite_vtk
+ read(10,*) nom_fich_coupev,nom_fich_drag
+ read(10,*) num_suite,sauv_cpt_ite,name_relance
+ close(10)
+
+
+ nx_gro=nx
+ ny_gro=nx_gro
+ nz_gro=nx_gro
+
+ dx=(xd-xg)/(nx-1.)
+ dy=(yh-yb)/(ny-1.)
+ dz=(zf-zd)/(nz-1.)
+
+ dx_gro=(xd-xg)/(nx_gro-1.)
+ dy_gro=(yh-yb)/(ny_gro-1.)
+ dz_gro=(zf-zd)/(nz_gro-1.)
+
+
+
+ !maxv=1.D0
+ !maxv=2.D0
+ !cfl=0.4D0
+
+
+ !dt=cfl*dx/maxv
+ !dt=0.0125
+ !dt=0.001
+ !dt=min(cfl*dx/maxv,cfl pour diffusion)
+ dt=0.005
+ !dt=0.01
+ !dt=3./8.*dx**2/nu
+
+ print*,"dt",dt
+
+ !
+ !calcul init
+ !-----------
+ cpt_ite=0
+ time=0.D0
+ ind_drag=0
+ if (num_suite==1) then
+ cpt_ite=sauv_cpt_ite
+ time=cpt_ite*dt
+ end if
+
+ npart=nx*ny*nz
+
+ nx=nx-1
+ ny=ny-1
+ nz=nz-1
+
+ nx_gro=nx_gro-1
+ ny_gro=ny_gro-1
+ nz_gro=nz_gro-1
+
+
+ PI=3.141592653589793238462643383279502884197D0
+
+
+ !
+ !alloc tableaux
+ !--------------
+ allocate (vxg(1:nx_gro,1:ny_gro,1:nz_gro),vyg(1:nx_gro,1:ny_gro,1:nz_gro),vzg(1:nx_gro,1:ny_gro,1:nz_gro))
+ allocate (omgx(1:nx,1:ny,1:nz),omgy(1:nx,1:ny,1:nz),omgz(1:nx,1:ny,1:nz))
+ allocate (xp(1:npart),qp(1:npart),vx(1:npart),yp(1:npart),vy(1:npart),zp(1:npart),vz(1:npart))
+ allocate (omx(1:npart),omy(1:npart),omz(1:npart))
+ allocate (xtab(1:nx),ytab(1:ny),ztab(1:nz))
+ allocate (chi(1:nx,1:ny,1:nz),chi_sphere(1:nx,1:ny,1:nz),lambda(1:nx,1:ny,1:nz))
+
+ !pour la correction de consistance
+ allocate (numpg(1:nx,1:ny,1:nz))
+ allocate (blocg(0:npart),blocd(0:npart),Nbloc(0:npart))
+
+
+ allocate (deb1(1:nx,1:ny,1:nz),deb2(1:nx,1:ny,1:nz),deb3(1:nx,1:ny,1:nz))
+
+ allocate(stxg(1:nx,1:ny,1:nz),styg(1:nx,1:ny,1:nz),stzg(1:nx,1:ny,1:nz))
+ allocate(stx(1:npart),sty(1:npart),stz(1:npart))
+
+ open(unit=12,file=trim(nom_fich_drag),form="formatted")
+ open(unit=13,file=trim(nom_fich_coupev),form="formatted")
+ open(unit=14,file="RES/test/fich1.deb",form="formatted")
+ open(unit=15,file="RES/test/fich2.deb",form="formatted")
+ open(unit=16,file="RES/test/fich3.deb",form="formatted")
+ open(unit=17,file="RES/test/fich4.deb",form="formatted")
+ open(unit=18,file="RES/test/fich5.deb",form="formatted")
+ open(unit=19,file="RES/test/fich6.deb",form="formatted")
+ open(unit=20,file="RES/test/fich7.deb",form="formatted")
+
+
+
+
+ !=================
+ !initialisations
+ !=================
+ call make_grille
+ call make_chi
+ call init_grille()
+
+ call res_vtk_chi(nom_fich_chi)
+ call res_vtk_lambda(nom_fich_lambda)
+ !============================================================
+ !test: v->w retrouve par fft
+ !
+ !si fonction en sin avec div=0 => erreur de 10-8
+ ! si " " " " div/=0 => erreur elevée
+ ! doit regulariser et avoir u1diff(chi,x1)+ u2diff(chi,x2)+ u3diff(chi,x3)=0
+ ! la vitesse apres penalisatin n'est pas à div nulle
+ ! mais celle calcule apres (a partir de la vorticite) est à div nulle
+ !=============================================================
+!!$ do k=1,nz
+!!$ z=ztab(k)
+!!$ do j=1,ny
+!!$ y=ytab(j)
+!!$ do i=1,nx
+!!$ x=xtab(i)
+!!$ !vxg(i,j,k)=(1.-(x**2+y**2+z**2))**6
+!!$ !if ( (x**2+y**2+z**2)>1. ) vxg(i,j,k)=0.
+!!$ !vxg(i,j,k)=cos(2.*Pi*x)!divu/=0
+!!$ vxg(i,j,k)=(1.-chi(i,j,k))*y
+!!$ !if ( (x**2+y**2+z**2)<0.5 ) vxg(i,j,k)=0.
+!!$ vyg(i,j,k)=(1.-chi(i,j,k))*(-x)
+!!$ vzg(i,j,k)=0.
+!!$
+!!$
+!!$
+!!$ !vxg(i,j,k)=2.*sin(pi*x)**2*sin(2.*pi*y)*sin(2.*pi*z)
+!!$ !vyg(i,j,k)=-sin(2.*pi*x)*sin(pi*y)**2*sin(2.*pi*z)
+!!$ !vzg(i,j,k)=-sin(2.*pi*x)*sin(2.*pi*y)*sin(pi*z)**2
+!!$
+!!$ end do
+!!$ end do
+!!$ end do
+!!$ call res_vtk_omega(trim("RES/vtk/test_omg1.vtk"))
+!!$ call res_vtk_vit(trim("RES/vtk/test_vg1.vtk"))
+!!$ deb1=vxg
+!!$ deb2=vyg
+!!$ deb3=vzg
+!!$
+!!$ call penal_fft ! calcul w=rot(v) par fft
+!!$
+!!$
+!!$
+!!$ call res_vtk_omega(trim("RES/vtk/test_omg2.vtk"))
+!!$
+!!$ call vitesse_fft_uinf
+!!$ !call vitesse_fft_uavt
+!!$ call res_vtk_vit(trim("RES/vtk/test_vg2.vtk"))
+!!$
+!!$ print*,"erreur"
+!!$ print*,maxval(abs(deb1-vxg)),maxval(abs(deb2-vyg)),maxval(abs(deb3-vzg))
+!!$ print*,"dx",dx
+!!$ stop
+
+
+
+ !===================
+ !iterations en temps
+ !===================
+
+ temps: do while(time<tfin)
+
+ if ((time+dt)>tfin) dt=tfin-time
+
+ !=======================
+ !calcul champ de vitesse
+ !========================
+ !call def_v_advec (vxg,vyg,vzg,time)
+ !call vitesse_fft
+ call cpu_time(t1)
+ call vitesse_fft_uinf
+ call cpu_time(t2)
+
+
+ !call imposer_debit(vxg,4.d0*2.06441*2.06441,nx,ny,nz,dx,dy,dz)
+
+ !call imposer_debit(vxg,1.d0,nx,ny,nz,dx,dy,dz)
+ !vxg=vxg+1./(4.*1.*1.5) !debit=debit voulu +c*surface du domaine num, c etant la constante à ajouter au champ de vitesse.
+
+ !test la valeur du débit
+ !-----------------------
+!!$ t4=0.
+!!$ do k=1,nz
+!!$ do j=1,ny
+!!$ t4=t4+vxg(1,j,k)
+!!$ end do
+!!$ end do
+!!$ print*, "debit i=1 ",t4*dy*dz
+!!$ print*,"bulk velocity",t4*dy*dz/(4.*(1./0.4854)**2)
+
+
+!-------------------------test calcul vitesse avec omg exact------------------------------------------------------
+!!$ indi1=1
+!!$ indi2=nx/2
+!!$ indk1=1
+!!$ indk2=nz/2
+!!$
+!!$ do indj=1,ny
+!!$ if ( ((yb+(indj-1)*dy).ge.-(1./0.4844)).and.((yb+(indj-1)*dy).le.(1./0.4844))) then
+!!$ vexa=1.5*(1.-(yb+(indj-1)*dy)**2/(1./0.4844)**2)
+!!$ omexa=3.*(yb+(indj-1)*dy)/((1./0.4844)**2)
+!!$ else
+!!$ vexa=0.
+!!$ omexa=0.
+!!$ end if
+!!$ write(14,'(8(e25.15,2x))') time,yb+(indj-1)*dy,vxg(indi1,indj,indk1),omgz(indi1,indj,indk1),vexa,omexa,vxg(indi2,indj,indk2),omgz(indi2,indj,indk2)
+!!$ end do
+!!$!stop
+!------------------------------------------------------------------------------------------------------
+
+
+
+ !penalisation: nouveau calcul de v
+ !---------------------------------
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+ !tmp=exp(-lambda*dt*chi(i,j,k))
+ tmp=1./(1.+lambda(i,j,k)*dt*chi(i,j,k))
+ vxg(i,j,k)=vxg(i,j,k)*tmp
+ vyg(i,j,k)=vyg(i,j,k)*tmp
+ vzg(i,j,k)=vzg(i,j,k)*tmp
+
+ end do
+ end do
+ end do
+
+ call cpu_time(t3)
+
+ !resultats
+ !---------
+
+ !-----------------(poiseuil en y)---------------------------------------
+!!$ call res_vtk_nite(nom_fich_omg_nite,nom_fich_vit_nite,nite_vtk,time)
+!!$ indi1=-xg/dx+1
+!!$ indi2=(0.7-xg)/dx+1
+!!$ indj=-yb/dy+1
+!!$ if (mod(cpt_ite,5)==0) then
+!!$ do indk=1,nz
+!!$ if ( ((zd+(indk-1)*dz).ge.-1.).and.((zd+(indk-1)*dz).le.1.)) then
+!!$ vexa=1.5*(1.-(zd+(indk-1)*dz)**2)/(4.*0.5*abs(yh-yb))
+!!$ omexa=-3.*(zd+(indk-1)*dz)/(4.*0.5*abs(yh-yb))
+!!$ else
+!!$ vexa=0.
+!!$ omexa=0.
+!!$ end if
+!!$ write(13,'(8(e25.15,2x))') time,zd+(indk-1)*dz,vxg(indi1,indj,indk),omgy(indi1,indj,indk),vexa,omexa,vxg(indi2,indj,indk),omgy(indi2,indj,indk)
+!!$ end do
+!!$ end if
+ !---------------------------------------------------------------------------
+
+
+ !-----------------(poiseuil en z)---------------------------------------
+! call res_vtk_nite(nom_fich_omg_nite,nom_fich_vit_nite,nite_vtk,time)
+ indi1=1
+ indi2=nx/2
+ indk1=1
+ indk2=nz/2
+ if (mod(cpt_ite,20)==0) then
+ do indj=1,ny
+ if ( ((yb+(indj-1)*dy).ge.-(1./0.4844)).and.((yb+(indj-1)*dy).le.(1./0.4844))) then
+ vexa=1.5*(1.-(yb+(indj-1)*dy)**2/(1./0.4844)**2)
+ omexa=3.*(yb+(indj-1)*dy)/((1./0.4844)**2)
+ else
+ vexa=0.
+ omexa=0.
+ end if
+ write(13,'(8(e25.15,2x))') time,yb+(indj-1)*dy,vxg(indi1,indj,indk1), &
+ omgz(indi1,indj,indk1),vexa,omexa,vxg(indi2,indj,indk2),omgz(indi2,indj,indk2)
+ end do
+ end if
+ !---------------------------------------------------------------------------
+
+
+ !================================================================================================
+ !algo penalisation "marche":
+ !
+ !penalisation:
+ !-------------
+ !si explicite: lambda<2/dt, mais drag poreux marche car vitesse dans obstacle de l'ordre de lambda
+ !si implicite: 1/peut pas mettre en terme source et 2/grandes vitesses dans l obstacle
+ ! (la formule developpe n'a pas l'air de marcher)
+ !==================================================================================================
+
+ !call penal_exacte()
+ !call strech_old
+ !call diffusion_old()
+
+
+ !===================================================================
+ !calcul du drag : !vitesse penalisee faible dans l'obstacle !
+ !====================================================================
+ dragi=drag_tps()
+ dragp=drag_poreux()
+ lifti=lift_tps()
+ liftp=lift_poreux()
+ if (time>dt) then
+ print*,"time",time
+ write(12,'(6(e25.15,2x))') time,time-dt,dragi,dragp,lifti,liftp
+ end if
+ if (ind_drag<5) ind_drag=ind_drag+1
+
+ !================================
+ !algo sans splitting
+ !================================
+
+ !call penal_fft !calcul omg=rot(v)
+ call rotv_df4
+ !call rotv_df2
+
+ call strech_diff_penal() ! penal commentee
+
+ call crea_part_old()
+
+ call advection_old() !RK2
+
+ call cpu_time(t4)
+
+ call remaill_l4(omx,xp,yp,zp,omgx)
+ call remaill_l4(omy,xp,yp,zp,omgy)
+ call remaill_l4(omz,xp,yp,zp,omgz)
+
+ call cpu_time(t5)
+
+
+!!$ !======================================
+!!$ !splitting en espace : ordre2 en temps
+!!$ !======================================
+!!$ call penal_exacte()
+!!$
+!!$
+!!$ call crea_part_x()
+!!$
+!!$ allocate(vxg1(1:nx_gro,1:ny_gro,1:nz_gro),vyg1(1:nx_gro,1:ny_gro,1:nz_gro),vzg1(1:nx_gro,1:ny_gro,1:nz_gro))
+!!$ !call def_v_advec (vxg1,vyg1,vzg1,time+0.5*dt)
+!!$ vxg1=vxg
+!!$ vyg1=vyg
+!!$ vzg1=vzg
+!!$
+!!$ !t source
+!!$ !---------
+!!$ call source_split_1
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vx_2
+!!$
+!!$ !test cfl
+!!$ !--------
+!!$ !grad=0.
+!!$ !do k=1,nz
+!!$ ! do j=1,ny
+!!$ ! do i=1,nx-1
+!!$ ! grad=max(grad,abs(vx(numpg(i+1,j,k))-vx(numpg(i,j,k))))
+!!$ ! !grad=max(grad,abs(vxg(i+1,j,k)-vxg(i,j,k)))
+!!$ ! end do
+!!$ ! end do
+!!$ !end do
+!!$ !print*,dt,dx/(4.*grad),dx/(6.*grad)
+!!$
+!!$
+!!$ !bloc x
+!!$ !-------
+!!$ !call make_bloc(1)
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_x
+!!$
+!!$
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_x(omx,xp,yp,zp,omgx)
+!!$ !call remaill_l6_x(omy,xp,yp,zp,omgy)
+!!$ !call remaill_l6_x(omz,xp,yp,zp,omgz)
+!!$ if (type_b==2) call remaill_l2_bloc_x(omx,xp,yp,zp,omgx)
+!!$ if (type_b==2) call remaill_l2_bloc_x(omy,xp,yp,zp,omgy)
+!!$ if (type_b==2) call remaill_l2_bloc_x(omz,xp,yp,zp,omgz)
+!!$ if (type_b==4) call remaill_l4_bloc_x(omx,xp,yp,zp,omgx)
+!!$ if (type_b==4) call remaill_l4_bloc_x(omy,xp,yp,zp,omgy)
+!!$ if (type_b==4) call remaill_l4_bloc_x(omz,xp,yp,zp,omgz)
+!!$
+!!$
+!!$ !y
+!!$ !--
+!!$ call crea_part_y()
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vy_2
+!!$
+!!$ !bloc y
+!!$ !-------
+!!$ !call make_bloc(2)
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_y
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_y(omx,xp,yp,zp,omgx)
+!!$ !call remaill_l6_y(omy,xp,yp,zp,omgy)
+!!$ !call remaill_l6_y(omz,xp,yp,zp,omgz)
+!!$ if (type_b==2)call remaill_l2_bloc_y(omx,xp,yp,zp,omgx)
+!!$ if (type_b==2)call remaill_l2_bloc_y(omy,xp,yp,zp,omgy)
+!!$ if (type_b==2)call remaill_l2_bloc_y(omz,xp,yp,zp,omgz)
+!!$ if (type_b==4)call remaill_l4_bloc_y(omx,xp,yp,zp,omgx)
+!!$ if (type_b==4)call remaill_l4_bloc_y(omy,xp,yp,zp,omgy)
+!!$ if (type_b==4)call remaill_l4_bloc_y(omz,xp,yp,zp,omgz)
+!!$
+!!$
+!!$ !z
+!!$ !--
+!!$ call crea_part_z()
+!!$
+!!$ !update v
+!!$ !--------
+!!$ call update_vz_2
+!!$
+!!$
+!!$ !bloc z
+!!$ !-------
+!!$ !call make_bloc(3)
+!!$ blocg=0
+!!$ blocd=0
+!!$
+!!$ !advection
+!!$ !----------
+!!$ call ad_euler_z
+!!$
+!!$ !remaillage
+!!$ !----------
+!!$ !call remaill_l6_z(omx,xp,yp,zp,omgx)
+!!$ !call remaill_l6_z(omy,xp,yp,zp,omgy)
+!!$ !call remaill_l6_z(omz,xp,yp,zp,omgz)
+!!$ if (type_b==2)call remaill_l2_bloc_z(omx,xp,yp,zp,omgx)
+!!$ if (type_b==2)call remaill_l2_bloc_z(omy,xp,yp,zp,omgy)
+!!$ if (type_b==2)call remaill_l2_bloc_z(omz,xp,yp,zp,omgz)
+!!$ if (type_b==4)call remaill_l4_bloc_z(omx,xp,yp,zp,omgx)
+!!$ if (type_b==4)call remaill_l4_bloc_z(omy,xp,yp,zp,omgy)
+!!$ if (type_b==4)call remaill_l4_bloc_z(omz,xp,yp,zp,omgz)
+!!$
+!!$
+!!$
+!!$ !t source
+!!$ !---------
+!!$ call source_split_2
+!!$
+!!$
+!!$ deallocate(vxg1,vyg1,vzg1)
+
+
+
+
+ time=time+dt
+ cpt_ite=cpt_ite+1
+
+ !resultats
+ !-----------
+
+ !call res_omg_nite(nom_fich_omg_nite,nom_fich_vit_nite,nite_vtk,time)
+
+
+
+!!$ print*,"tps"
+!!$ print*,""
+!!$ print*,"u fourier",t2-t1
+!!$ print*,"penal",t3-t2
+!!$ print*,"remaillage",t5-t4
+
+
+ end do temps
+
+
+
+
+
+
+ !resultat final
+ !--------------
+ print*,"tps final",time
+ print*,"nbre d'ite",cpt_ite
+ print*,"nart final",npart
+ print*,"dt,dx,dy,dz",dt,dx,dy,dz
+
+
+
+ !call res_vtk("RES/vtk/"//nom_fich_vtk)
+ !call res_vtk_omgx("RES/vtk/"//nom_fich_vtk)
+
+
+
+ !
+ !dealloc fermeture
+ !-----------------
+
+ deallocate (xp,qp,vx,vy,yp,zp,vz)
+ deallocate (omgx,omgy,omgz)
+ deallocate (omx,omy,omz)
+ deallocate (vxg,vyg,vzg)
+ deallocate (xtab,ytab,ztab)
+ deallocate (chi,chi_sphere,lambda)
+ deallocate (deb1,deb2,deb3)
+
+ deallocate(stxg,styg,stzg,stx,sty,stz)
+
+ close(12)
+ close(13)
+ close(14)
+ close(15)
+ close(16)
+ close(17)
+ close(18)
+ close(19)
+ close(20)
+
+end program NS
+
+
+
+
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/nr.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/nr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4d535a314078046686cad474d138d37aac888256
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/nr.f90
@@ -0,0 +1,2990 @@
+MODULE nr
+ INTERFACE
+ SUBROUTINE airy(x,ai,bi,aip,bip)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: ai,bi,aip,bip
+ END SUBROUTINE airy
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr)
+ USE nrtype
+ INTEGER(I4B), INTENT(INOUT) :: iter
+ REAL(SP), INTENT(INOUT) :: yb
+ REAL(SP), INTENT(IN) :: ftol,temptr
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE amebsa
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE amoeba(p,y,ftol,func,iter)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: iter
+ REAL(SP), INTENT(IN) :: ftol
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE amoeba
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE anneal(x,y,iorder)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ END SUBROUTINE anneal
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE avevar(data,ave,var)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data
+ REAL(SP), INTENT(OUT) :: ave,var
+ END SUBROUTINE avevar
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE balanc(a)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ END SUBROUTINE balanc
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE banbks(a,m1,m2,al,indx,b)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: m1,m2
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
+ END SUBROUTINE banbks
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE bandec(a,m1,m2,al,indx,d)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: m1,m2
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
+ REAL(SP), INTENT(OUT) :: d
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al
+ END SUBROUTINE bandec
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE banmul(a,m1,m2,x,b)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: m1,m2
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: b
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ END SUBROUTINE banmul
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: d1,d2
+ REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12
+ REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c
+ END SUBROUTINE bcucof
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,&
+ ansy1,ansy2)
+ USE nrtype
+ REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12
+ REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2
+ REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2
+ END SUBROUTINE bcuint
+ END INTERFACE
+ INTERFACE bessi
+ FUNCTION bessi_s(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessi_s
+ END FUNCTION bessi_s
+!BL
+ FUNCTION bessi_v(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessi_v
+ END FUNCTION bessi_v
+ END INTERFACE
+ INTERFACE bessi0
+ FUNCTION bessi0_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessi0_s
+ END FUNCTION bessi0_s
+!BL
+ FUNCTION bessi0_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessi0_v
+ END FUNCTION bessi0_v
+ END INTERFACE
+ INTERFACE bessi1
+ FUNCTION bessi1_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessi1_s
+ END FUNCTION bessi1_s
+!BL
+ FUNCTION bessi1_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessi1_v
+ END FUNCTION bessi1_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,xnu
+ REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp
+ END SUBROUTINE bessik
+ END INTERFACE
+ INTERFACE bessj
+ FUNCTION bessj_s(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessj_s
+ END FUNCTION bessj_s
+!BL
+ FUNCTION bessj_v(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessj_v
+ END FUNCTION bessj_v
+ END INTERFACE
+ INTERFACE bessj0
+ FUNCTION bessj0_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessj0_s
+ END FUNCTION bessj0_s
+!BL
+ FUNCTION bessj0_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessj0_v
+ END FUNCTION bessj0_v
+ END INTERFACE
+ INTERFACE bessj1
+ FUNCTION bessj1_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessj1_s
+ END FUNCTION bessj1_s
+!BL
+ FUNCTION bessj1_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessj1_v
+ END FUNCTION bessj1_v
+ END INTERFACE
+ INTERFACE bessjy
+ SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,xnu
+ REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp
+ END SUBROUTINE bessjy_s
+!BL
+ SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: xnu
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp
+ END SUBROUTINE bessjy_v
+ END INTERFACE
+ INTERFACE bessk
+ FUNCTION bessk_s(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessk_s
+ END FUNCTION bessk_s
+!BL
+ FUNCTION bessk_v(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessk_v
+ END FUNCTION bessk_v
+ END INTERFACE
+ INTERFACE bessk0
+ FUNCTION bessk0_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessk0_s
+ END FUNCTION bessk0_s
+!BL
+ FUNCTION bessk0_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessk0_v
+ END FUNCTION bessk0_v
+ END INTERFACE
+ INTERFACE bessk1
+ FUNCTION bessk1_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessk1_s
+ END FUNCTION bessk1_s
+!BL
+ FUNCTION bessk1_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessk1_v
+ END FUNCTION bessk1_v
+ END INTERFACE
+ INTERFACE bessy
+ FUNCTION bessy_s(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessy_s
+ END FUNCTION bessy_s
+!BL
+ FUNCTION bessy_v(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessy_v
+ END FUNCTION bessy_v
+ END INTERFACE
+ INTERFACE bessy0
+ FUNCTION bessy0_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessy0_s
+ END FUNCTION bessy0_s
+!BL
+ FUNCTION bessy0_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessy0_v
+ END FUNCTION bessy0_v
+ END INTERFACE
+ INTERFACE bessy1
+ FUNCTION bessy1_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: bessy1_s
+ END FUNCTION bessy1_s
+!BL
+ FUNCTION bessy1_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: bessy1_v
+ END FUNCTION bessy1_v
+ END INTERFACE
+ INTERFACE beta
+ FUNCTION beta_s(z,w)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: z,w
+ REAL(SP) :: beta_s
+ END FUNCTION beta_s
+!BL
+ FUNCTION beta_v(z,w)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: z,w
+ REAL(SP), DIMENSION(size(z)) :: beta_v
+ END FUNCTION beta_v
+ END INTERFACE
+ INTERFACE betacf
+ FUNCTION betacf_s(a,b,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b,x
+ REAL(SP) :: betacf_s
+ END FUNCTION betacf_s
+!BL
+ FUNCTION betacf_v(a,b,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x
+ REAL(SP), DIMENSION(size(x)) :: betacf_v
+ END FUNCTION betacf_v
+ END INTERFACE
+ INTERFACE betai
+ FUNCTION betai_s(a,b,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b,x
+ REAL(SP) :: betai_s
+ END FUNCTION betai_s
+!BL
+ FUNCTION betai_v(a,b,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x
+ REAL(SP), DIMENSION(size(a)) :: betai_v
+ END FUNCTION betai_v
+ END INTERFACE
+ INTERFACE bico
+ FUNCTION bico_s(n,k)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n,k
+ REAL(SP) :: bico_s
+ END FUNCTION bico_s
+!BL
+ FUNCTION bico_v(n,k)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k
+ REAL(SP), DIMENSION(size(n)) :: bico_v
+ END FUNCTION bico_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION bnldev(pp,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: pp
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP) :: bnldev
+ END FUNCTION bnldev
+ END INTERFACE
+ INTERFACE
+ FUNCTION brent(ax,bx,cx,func,tol,xmin)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: ax,bx,cx,tol
+ REAL(SP), INTENT(OUT) :: xmin
+ REAL(SP) :: brent
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION brent
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE broydn(x,check)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ LOGICAL(LGT), INTENT(OUT) :: check
+ END SUBROUTINE broydn
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
+ REAL(SP), INTENT(INOUT) :: x
+ REAL(SP), INTENT(IN) :: htry,eps
+ REAL(SP), INTENT(OUT) :: hdid,hnext
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE bsstep
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE caldat(julian,mm,id,iyyy)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: julian
+ INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy
+ END SUBROUTINE caldat
+ END INTERFACE
+ INTERFACE
+ FUNCTION chder(a,b,c)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c
+ REAL(SP), DIMENSION(size(c)) :: chder
+ END FUNCTION chder
+ END INTERFACE
+ INTERFACE chebev
+ FUNCTION chebev_s(a,b,c,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b,x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c
+ REAL(SP) :: chebev_s
+ END FUNCTION chebev_s
+!BL
+ FUNCTION chebev_v(a,b,c,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c,x
+ REAL(SP), DIMENSION(size(x)) :: chebev_v
+ END FUNCTION chebev_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION chebft(a,b,n,func)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: chebft
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION chebft
+ END INTERFACE
+ INTERFACE
+ FUNCTION chebpc(c)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c
+ REAL(SP), DIMENSION(size(c)) :: chebpc
+ END FUNCTION chebpc
+ END INTERFACE
+ INTERFACE
+ FUNCTION chint(a,b,c)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c
+ REAL(SP), DIMENSION(size(c)) :: chint
+ END FUNCTION chint
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE choldc(a,p)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: p
+ END SUBROUTINE choldc
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cholsl(a,p,b,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ REAL(SP), DIMENSION(:), INTENT(IN) :: p,b
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ END SUBROUTINE cholsl
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: knstrn
+ REAL(SP), INTENT(OUT) :: df,chsq,prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins
+ END SUBROUTINE chsone
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: knstrn
+ REAL(SP), INTENT(OUT) :: df,chsq,prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2
+ END SUBROUTINE chstwo
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cisi(x,ci,si)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: ci,si
+ END SUBROUTINE cisi
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn
+ REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc
+ END SUBROUTINE cntab1
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn
+ REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy
+ END SUBROUTINE cntab2
+ END INTERFACE
+ INTERFACE
+ FUNCTION convlv(data,respns,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data
+ REAL(SP), DIMENSION(:), INTENT(IN) :: respns
+ INTEGER(I4B), INTENT(IN) :: isign
+ REAL(SP), DIMENSION(size(data)) :: convlv
+ END FUNCTION convlv
+ END INTERFACE
+ INTERFACE
+ FUNCTION correl(data1,data2)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ REAL(SP), DIMENSION(size(data1)) :: correl
+ END FUNCTION correl
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cosft1(y)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ END SUBROUTINE cosft1
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cosft2(y,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE cosft2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE covsrt(covar,maska)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
+ END SUBROUTINE covsrt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE cyclic(a,b,c,alpha,beta,r,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r
+ REAL(SP), INTENT(IN) :: alpha,beta
+ REAL(SP), DIMENSION(:), INTENT(OUT):: x
+ END SUBROUTINE cyclic
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE daub4(a,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE daub4
+ END INTERFACE
+ INTERFACE dawson
+ FUNCTION dawson_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: dawson_s
+ END FUNCTION dawson_s
+!BL
+ FUNCTION dawson_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: dawson_v
+ END FUNCTION dawson_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: ax,bx,cx,tol
+ REAL(SP), INTENT(OUT) :: xmin
+ REAL(SP) :: dbrent
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+!BL
+ FUNCTION dbrent_dfunc(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: dbrent_dfunc
+ END FUNCTION dbrent_dfunc
+ END INTERFACE
+ END FUNCTION dbrent
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ddpoly(c,x,pd)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: pd
+ END SUBROUTINE ddpoly
+ END INTERFACE
+ INTERFACE
+ FUNCTION decchk(string,ch)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: string
+ CHARACTER(1), INTENT(OUT) :: ch
+ LOGICAL(LGT) :: decchk
+ END FUNCTION decchk
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: iter
+ REAL(SP), INTENT(IN) :: gtol
+ REAL(SP), INTENT(OUT) :: fret
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
+ INTERFACE
+ FUNCTION func(p)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: p
+ REAL(SP) :: func
+ END FUNCTION func
+!BL
+ FUNCTION dfunc(p)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: p
+ REAL(SP), DIMENSION(size(p)) :: dfunc
+ END FUNCTION dfunc
+ END INTERFACE
+ END SUBROUTINE dfpmin
+ END INTERFACE
+ INTERFACE
+ FUNCTION dfridr(func,x,h,err)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,h
+ REAL(SP), INTENT(OUT) :: err
+ REAL(SP) :: dfridr
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION dfridr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: w,delta,a,b
+ REAL(SP), INTENT(OUT) :: corre,corim,corfac
+ REAL(SP), DIMENSION(:), INTENT(IN) :: endpts
+ END SUBROUTINE dftcor
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE dftint(func,a,b,w,cosint,sinint)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b,w
+ REAL(SP), INTENT(OUT) :: cosint,sinint
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE dftint
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: y
+ END SUBROUTINE difeq
+ END INTERFACE
+ INTERFACE
+ FUNCTION eclass(lista,listb,n)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), DIMENSION(n) :: eclass
+ END FUNCTION eclass
+ END INTERFACE
+ INTERFACE
+ FUNCTION eclazz(equiv,n)
+ USE nrtype
+ INTERFACE
+ FUNCTION equiv(i,j)
+ USE nrtype
+ LOGICAL(LGT) :: equiv
+ INTEGER(I4B), INTENT(IN) :: i,j
+ END FUNCTION equiv
+ END INTERFACE
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), DIMENSION(n) :: eclazz
+ END FUNCTION eclazz
+ END INTERFACE
+ INTERFACE
+ FUNCTION ei(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: ei
+ END FUNCTION ei
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE eigsrt(d,v)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v
+ END SUBROUTINE eigsrt
+ END INTERFACE
+ INTERFACE elle
+ FUNCTION elle_s(phi,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: phi,ak
+ REAL(SP) :: elle_s
+ END FUNCTION elle_s
+!BL
+ FUNCTION elle_v(phi,ak)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak
+ REAL(SP), DIMENSION(size(phi)) :: elle_v
+ END FUNCTION elle_v
+ END INTERFACE
+ INTERFACE ellf
+ FUNCTION ellf_s(phi,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: phi,ak
+ REAL(SP) :: ellf_s
+ END FUNCTION ellf_s
+!BL
+ FUNCTION ellf_v(phi,ak)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak
+ REAL(SP), DIMENSION(size(phi)) :: ellf_v
+ END FUNCTION ellf_v
+ END INTERFACE
+ INTERFACE ellpi
+ FUNCTION ellpi_s(phi,en,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: phi,en,ak
+ REAL(SP) :: ellpi_s
+ END FUNCTION ellpi_s
+!BL
+ FUNCTION ellpi_v(phi,en,ak)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak
+ REAL(SP), DIMENSION(size(phi)) :: ellpi_v
+ END FUNCTION ellpi_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE elmhes(a)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ END SUBROUTINE elmhes
+ END INTERFACE
+ INTERFACE erf
+ FUNCTION erf_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: erf_s
+ END FUNCTION erf_s
+!BL
+ FUNCTION erf_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: erf_v
+ END FUNCTION erf_v
+ END INTERFACE
+ INTERFACE erfc
+ FUNCTION erfc_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: erfc_s
+ END FUNCTION erfc_s
+!BL
+ FUNCTION erfc_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: erfc_v
+ END FUNCTION erfc_v
+ END INTERFACE
+ INTERFACE erfcc
+ FUNCTION erfcc_s(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: erfcc_s
+ END FUNCTION erfcc_s
+!BL
+ FUNCTION erfcc_v(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: erfcc_v
+ END FUNCTION erfcc_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE eulsum(sum,term,jterm)
+ USE nrtype
+ REAL(SP), INTENT(INOUT) :: sum
+ REAL(SP), INTENT(IN) :: term
+ INTEGER(I4B), INTENT(IN) :: jterm
+ END SUBROUTINE eulsum
+ END INTERFACE
+ INTERFACE
+ FUNCTION evlmem(fdt,d,xms)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: fdt,xms
+ REAL(SP), DIMENSION(:), INTENT(IN) :: d
+ REAL(SP) :: evlmem
+ END FUNCTION evlmem
+ END INTERFACE
+ INTERFACE expdev
+ SUBROUTINE expdev_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE expdev_s
+!BL
+ SUBROUTINE expdev_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE expdev_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION expint(n,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: expint
+ END FUNCTION expint
+ END INTERFACE
+ INTERFACE factln
+ FUNCTION factln_s(n)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP) :: factln_s
+ END FUNCTION factln_s
+!BL
+ FUNCTION factln_v(n)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n
+ REAL(SP), DIMENSION(size(n)) :: factln_v
+ END FUNCTION factln_v
+ END INTERFACE
+ INTERFACE factrl
+ FUNCTION factrl_s(n)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP) :: factrl_s
+ END FUNCTION factrl_s
+!BL
+ FUNCTION factrl_v(n)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n
+ REAL(SP), DIMENSION(size(n)) :: factrl_v
+ END FUNCTION factrl_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), INTENT(IN) :: ofac,hifac
+ INTEGER(I4B), INTENT(OUT) :: jmax
+ REAL(SP), INTENT(OUT) :: prob
+ REAL(SP), DIMENSION(:), POINTER :: px,py
+ END SUBROUTINE fasper
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fdjac(x,fvec,df)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: fvec
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df
+ END SUBROUTINE fdjac
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fgauss(x,a,y,dyda)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: y
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
+ END SUBROUTINE fgauss
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q
+ REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig
+ END SUBROUTINE fit
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy
+ REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q
+ END SUBROUTINE fitexy
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fixrts(d)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
+ END SUBROUTINE fixrts
+ END INTERFACE
+ INTERFACE
+ FUNCTION fleg(x,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: fleg
+ END FUNCTION fleg
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE flmoon(n,nph,jd,frac)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n,nph
+ INTEGER(I4B), INTENT(OUT) :: jd
+ REAL(SP), INTENT(OUT) :: frac
+ END SUBROUTINE flmoon
+ END INTERFACE
+ INTERFACE four1
+!BL
+ SUBROUTINE four1_sp(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE four1_sp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four1_alt(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE four1_alt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four1_gather(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE four1_gather
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four2(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B),INTENT(IN) :: isign
+ END SUBROUTINE four2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four2_alt(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE four2_alt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four3(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B),INTENT(IN) :: isign
+ END SUBROUTINE four3
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE four3_alt(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE four3_alt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fourcol(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE fourcol
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fourcol_3d(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE fourcol_3d
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fourn_gather(data,nn,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE fourn_gather
+ END INTERFACE
+ INTERFACE fourrow
+!BL
+ SUBROUTINE fourrow_sp(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE fourrow_sp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fourrow_3d(data,isign)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE fourrow_3d
+ END INTERFACE
+ INTERFACE
+ FUNCTION fpoly(x,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: fpoly
+ END FUNCTION fpoly
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE fred2(a,b,t,f,w,g,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w
+ INTERFACE
+ FUNCTION g(t)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: t
+ REAL(SP), DIMENSION(size(t)) :: g
+ END FUNCTION g
+!BL
+ FUNCTION ak(t,s)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: t,s
+ REAL(SP), DIMENSION(size(t),size(s)) :: ak
+ END FUNCTION ak
+ END INTERFACE
+ END SUBROUTINE fred2
+ END INTERFACE
+ INTERFACE
+ FUNCTION fredin(x,a,b,t,f,w,g,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w
+ REAL(SP), DIMENSION(size(x)) :: fredin
+ INTERFACE
+ FUNCTION g(t)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: t
+ REAL(SP), DIMENSION(size(t)) :: g
+ END FUNCTION g
+!BL
+ FUNCTION ak(t,s)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: t,s
+ REAL(SP), DIMENSION(size(t),size(s)) :: ak
+ END FUNCTION ak
+ END INTERFACE
+ END FUNCTION fredin
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE frenel(x,s,c)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: s,c
+ END SUBROUTINE frenel
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE frprmn(p,ftol,iter,fret)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: iter
+ REAL(SP), INTENT(IN) :: ftol
+ REAL(SP), INTENT(OUT) :: fret
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
+ END SUBROUTINE frprmn
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ftest(data1,data2,f,prob)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: f,prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ END SUBROUTINE ftest
+ END INTERFACE
+ INTERFACE
+ FUNCTION gamdev(ia)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: ia
+ REAL(SP) :: gamdev
+ END FUNCTION gamdev
+ END INTERFACE
+ INTERFACE gammln
+ FUNCTION gammln_s(xx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: xx
+ REAL(SP) :: gammln_s
+ END FUNCTION gammln_s
+!BL
+ FUNCTION gammln_v(xx)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xx
+ REAL(SP), DIMENSION(size(xx)) :: gammln_v
+ END FUNCTION gammln_v
+ END INTERFACE
+ INTERFACE gammp
+ FUNCTION gammp_s(a,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,x
+ REAL(SP) :: gammp_s
+ END FUNCTION gammp_s
+!BL
+ FUNCTION gammp_v(a,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
+ REAL(SP), DIMENSION(size(a)) :: gammp_v
+ END FUNCTION gammp_v
+ END INTERFACE
+ INTERFACE gammq
+ FUNCTION gammq_s(a,x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,x
+ REAL(SP) :: gammq_s
+ END FUNCTION gammq_s
+!BL
+ FUNCTION gammq_v(a,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
+ REAL(SP), DIMENSION(size(a)) :: gammq_v
+ END FUNCTION gammq_v
+ END INTERFACE
+ INTERFACE gasdev
+ SUBROUTINE gasdev_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE gasdev_s
+!BL
+ SUBROUTINE gasdev_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE gasdev_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gaucof(a,b,amu0,x,w)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: amu0
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
+ END SUBROUTINE gaucof
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gauher(x,w)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
+ END SUBROUTINE gauher
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gaujac(x,w,alf,bet)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: alf,bet
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
+ END SUBROUTINE gaujac
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gaulag(x,w,alf)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: alf
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
+ END SUBROUTINE gaulag
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gauleg(x1,x2,x,w)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w
+ END SUBROUTINE gauleg
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE gaussj(a,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b
+ END SUBROUTINE gaussj
+ END INTERFACE
+ INTERFACE gcf
+ FUNCTION gcf_s(a,x,gln)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,x
+ REAL(SP), OPTIONAL, INTENT(OUT) :: gln
+ REAL(SP) :: gcf_s
+ END FUNCTION gcf_s
+!BL
+ FUNCTION gcf_v(a,x,gln)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
+ REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
+ REAL(SP), DIMENSION(size(a)) :: gcf_v
+ END FUNCTION gcf_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION golden(ax,bx,cx,func,tol,xmin)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: ax,bx,cx,tol
+ REAL(SP), INTENT(OUT) :: xmin
+ REAL(SP) :: golden
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION golden
+ END INTERFACE
+ INTERFACE gser
+ FUNCTION gser_s(a,x,gln)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,x
+ REAL(SP), OPTIONAL, INTENT(OUT) :: gln
+ REAL(SP) :: gser_s
+ END FUNCTION gser_s
+!BL
+ FUNCTION gser_v(a,x,gln)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
+ REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
+ REAL(SP), DIMENSION(size(a)) :: gser_v
+ END FUNCTION gser_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE hqr(a,wr,wi)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ END SUBROUTINE hqr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE hunt(xx,x,jlo)
+ USE nrtype
+ INTEGER(I4B), INTENT(INOUT) :: jlo
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xx
+ END SUBROUTINE hunt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE hypdrv(s,ry,rdyds)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: s
+ REAL(SP), DIMENSION(:), INTENT(IN) :: ry
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds
+ END SUBROUTINE hypdrv
+ END INTERFACE
+ INTERFACE
+ FUNCTION hypgeo(a,b,c,z)
+ USE nrtype
+ COMPLEX(SPC), INTENT(IN) :: a,b,c,z
+ COMPLEX(SPC) :: hypgeo
+ END FUNCTION hypgeo
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE hypser(a,b,c,z,series,deriv)
+ USE nrtype
+ COMPLEX(SPC), INTENT(IN) :: a,b,c,z
+ COMPLEX(SPC), INTENT(OUT) :: series,deriv
+ END SUBROUTINE hypser
+ END INTERFACE
+ INTERFACE
+ FUNCTION icrc(crc,buf,jinit,jrev)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf
+ INTEGER(I2B), INTENT(IN) :: crc,jinit
+ INTEGER(I4B), INTENT(IN) :: jrev
+ INTEGER(I2B) :: icrc
+ END FUNCTION icrc
+ END INTERFACE
+ INTERFACE
+ FUNCTION igray(n,is)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n,is
+ INTEGER(I4B) :: igray
+ END FUNCTION igray
+ END INTERFACE
+ INTERFACE
+ RECURSIVE SUBROUTINE index_bypack(arr,index,partial)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index
+ INTEGER, OPTIONAL, INTENT(IN) :: partial
+ END SUBROUTINE index_bypack
+ END INTERFACE
+ INTERFACE indexx
+ SUBROUTINE indexx_sp(arr,index)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index
+ END SUBROUTINE indexx_sp
+ SUBROUTINE indexx_i4b(iarr,index)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index
+ END SUBROUTINE indexx_i4b
+ END INTERFACE
+ INTERFACE
+ FUNCTION rank(indx)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
+ INTEGER(I4B), DIMENSION(size(indx)) :: rank
+ END FUNCTION rank
+ END INTERFACE
+ INTERFACE
+ FUNCTION irbit1(iseed)
+ USE nrtype
+ INTEGER(I4B), INTENT(INOUT) :: iseed
+ INTEGER(I4B) :: irbit1
+ END FUNCTION irbit1
+ END INTERFACE
+ INTERFACE
+ FUNCTION irbit2(iseed)
+ USE nrtype
+ INTEGER(I4B), INTENT(INOUT) :: iseed
+ INTEGER(I4B) :: irbit2
+ END FUNCTION irbit2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE jacobi(a,d,v,nrot)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: nrot
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: d
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
+ END SUBROUTINE jacobi
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE jacobn(x,y,dfdx,dfdy)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy
+ END SUBROUTINE jacobn
+ END INTERFACE
+ INTERFACE
+ FUNCTION julday(mm,id,iyyy)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: mm,id,iyyy
+ INTEGER(I4B) :: julday
+ END FUNCTION julday
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE kendl1(data1,data2,tau,z,prob)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: tau,z,prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ END SUBROUTINE kendl1
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE kendl2(tab,tau,z,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab
+ REAL(SP), INTENT(OUT) :: tau,z,prob
+ END SUBROUTINE kendl2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1
+ REAL(SP), INTENT(OUT) :: d1,prob
+ INTERFACE
+ SUBROUTINE quadvl(x,y,fa,fb,fc,fd)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y
+ REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
+ END SUBROUTINE quadvl
+ END INTERFACE
+ END SUBROUTINE ks2d1s
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2
+ REAL(SP), INTENT(OUT) :: d,prob
+ END SUBROUTINE ks2d2s
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ksone(data,func,d,prob)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: d,prob
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE ksone
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE kstwo(data1,data2,d,prob)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: d,prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ END SUBROUTINE kstwo
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE laguer(a,x,its)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: its
+ COMPLEX(SPC), INTENT(INOUT) :: x
+ COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
+ END SUBROUTINE laguer
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar
+ REAL(SP), INTENT(OUT) :: chisq
+ INTERFACE
+ SUBROUTINE funcs(x,arr)
+ USE nrtype
+ REAL(SP),INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: arr
+ END SUBROUTINE funcs
+ END INTERFACE
+ END SUBROUTINE lfit
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE linmin(p,xi,fret)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: fret
+ REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi
+ END SUBROUTINE linmin
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
+ REAL(SP), INTENT(IN) :: fold,stpmax
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x
+ REAL(SP), INTENT(OUT) :: f
+ LOGICAL(LGT), INTENT(OUT) :: check
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP) :: func
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE lnsrch
+ END INTERFACE
+ INTERFACE
+ FUNCTION locate(xx,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xx
+ REAL(SP), INTENT(IN) :: x
+ INTEGER(I4B) :: locate
+ END FUNCTION locate
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE lubksb(a,indx,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
+ END SUBROUTINE lubksb
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ludcmp(a,indx,d)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
+ REAL(SP), INTENT(OUT) :: d
+ END SUBROUTINE ludcmp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,&
+ maxexp,eps,epsneg,xmin,xmax)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,&
+ minexp,negep,ngrd
+ REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin
+ END SUBROUTINE machar
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE medfit(x,y,a,b,abdev)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), INTENT(OUT) :: a,b,abdev
+ END SUBROUTINE medfit
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE memcof(data,xms,d)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: xms
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: d
+ END SUBROUTINE memcof
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE midexp(funk,aa,bb,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: aa,bb
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION funk(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: funk
+ END FUNCTION funk
+ END INTERFACE
+ END SUBROUTINE midexp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE midinf(funk,aa,bb,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: aa,bb
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION funk(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: funk
+ END FUNCTION funk
+ END INTERFACE
+ END SUBROUTINE midinf
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE midpnt(func,a,b,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE midpnt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE midsql(funk,aa,bb,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: aa,bb
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION funk(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: funk
+ END FUNCTION funk
+ END INTERFACE
+ END SUBROUTINE midsql
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE midsqu(funk,aa,bb,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: aa,bb
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION funk(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: funk
+ END FUNCTION funk
+ END INTERFACE
+ END SUBROUTINE midsqu
+ END INTERFACE
+ INTERFACE
+ RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var)
+ USE nrtype
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP) :: func
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ END FUNCTION func
+ END INTERFACE
+ REAL(SP), DIMENSION(:), INTENT(IN) :: regn
+ INTEGER(I4B), INTENT(IN) :: ndim,npts
+ REAL(SP), INTENT(IN) :: dith
+ REAL(SP), INTENT(OUT) :: ave,var
+ END SUBROUTINE miser
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: nstep
+ REAL(SP), INTENT(IN) :: xs,htot
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE mmid
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func)
+ USE nrtype
+ REAL(SP), INTENT(INOUT) :: ax,bx
+ REAL(SP), INTENT(OUT) :: cx,fa,fb,fc
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE mnbrak
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: ntrial
+ REAL(SP), INTENT(IN) :: tolx,tolf
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ INTERFACE
+ SUBROUTINE usrfun(x,fvec,fjac)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac
+ END SUBROUTINE usrfun
+ END INTERFACE
+ END SUBROUTINE mnewt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data
+ END SUBROUTINE moment
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mp2dfr(a,s,n,m)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), INTENT(OUT) :: m
+ CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a
+ CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s
+ END SUBROUTINE mp2dfr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mpdiv(q,r,u,v,n,m)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v
+ INTEGER(I4B), INTENT(IN) :: n,m
+ END SUBROUTINE mpdiv
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mpinv(u,v,n,m)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: v
+ INTEGER(I4B), INTENT(IN) :: n,m
+ END SUBROUTINE mpinv
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mpmul(w,u,v,n,m)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v
+ CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w
+ INTEGER(I4B), INTENT(IN) :: n,m
+ END SUBROUTINE mpmul
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mppi(n)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ END SUBROUTINE mppi
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mprove(a,alud,indx,b,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx
+ REAL(SP), DIMENSION(:), INTENT(IN) :: b
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ END SUBROUTINE mprove
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mpsqrt(w,u,v,n,m)
+ USE nrtype
+ CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u
+ CHARACTER(1), DIMENSION(:), INTENT(IN) :: v
+ INTEGER(I4B), INTENT(IN) :: n,m
+ END SUBROUTINE mpsqrt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: beta
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha
+ REAL(SP), INTENT(OUT) :: chisq
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
+ INTERFACE
+ SUBROUTINE funcs(x,a,yfit,dyda)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
+ END SUBROUTINE funcs
+ END INTERFACE
+ END SUBROUTINE mrqcof
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha
+ REAL(SP), INTENT(OUT) :: chisq
+ REAL(SP), INTENT(INOUT) :: alamda
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
+ INTERFACE
+ SUBROUTINE funcs(x,a,yfit,dyda)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
+ END SUBROUTINE funcs
+ END INTERFACE
+ END SUBROUTINE mrqmin
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE newt(x,check)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: x
+ LOGICAL(LGT), INTENT(OUT) :: check
+ END SUBROUTINE newt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart
+ REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+!BL
+ SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
+ REAL(SP), INTENT(INOUT) :: x
+ REAL(SP), INTENT(IN) :: htry,eps
+ REAL(SP), INTENT(OUT) :: hdid,hnext
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE rkqs
+ END INTERFACE
+ END SUBROUTINE odeint
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE orthog(anu,alpha,beta,a,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b
+ END SUBROUTINE orthog
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pade(cof,resid)
+ USE nrtype
+ REAL(DP), DIMENSION(:), INTENT(INOUT) :: cof
+ REAL(SP), INTENT(OUT) :: resid
+ END SUBROUTINE pade
+ END INTERFACE
+ INTERFACE
+ FUNCTION pccheb(d)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: d
+ REAL(SP), DIMENSION(size(d)) :: pccheb
+ END FUNCTION pccheb
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pcshft(a,b,d)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: d
+ END SUBROUTINE pcshft
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pearsn(x,y,r,prob,z)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: r,prob,z
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ END SUBROUTINE pearsn
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob)
+ USE nrtype
+ INTEGER(I4B), INTENT(OUT) :: jmax
+ REAL(SP), INTENT(IN) :: ofac,hifac
+ REAL(SP), INTENT(OUT) :: prob
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), DIMENSION(:), POINTER :: px,py
+ END SUBROUTINE period
+ END INTERFACE
+ INTERFACE plgndr
+ FUNCTION plgndr_s(l,m,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: l,m
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: plgndr_s
+ END FUNCTION plgndr_s
+!BL
+ FUNCTION plgndr_v(l,m,x)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: l,m
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: plgndr_v
+ END FUNCTION plgndr_v
+ END INTERFACE
+ INTERFACE
+ FUNCTION poidev(xm)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: xm
+ REAL(SP) :: poidev
+ END FUNCTION poidev
+ END INTERFACE
+ INTERFACE
+ FUNCTION polcoe(x,y)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), DIMENSION(size(x)) :: polcoe
+ END FUNCTION polcoe
+ END INTERFACE
+ INTERFACE
+ FUNCTION polcof(xa,ya)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
+ REAL(SP), DIMENSION(size(xa)) :: polcof
+ END FUNCTION polcof
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE poldiv(u,v,q,r)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: u,v
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r
+ END SUBROUTINE poldiv
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya
+ REAL(SP), INTENT(IN) :: x1,x2
+ REAL(SP), INTENT(OUT) :: y,dy
+ END SUBROUTINE polin2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE polint(xa,ya,x,y,dy)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: y,dy
+ END SUBROUTINE polint
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE powell(p,xi,ftol,iter,fret)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi
+ INTEGER(I4B), INTENT(OUT) :: iter
+ REAL(SP), INTENT(IN) :: ftol
+ REAL(SP), INTENT(OUT) :: fret
+ END SUBROUTINE powell
+ END INTERFACE
+ INTERFACE
+ FUNCTION predic(data,d,nfut)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data,d
+ INTEGER(I4B), INTENT(IN) :: nfut
+ REAL(SP), DIMENSION(nfut) :: predic
+ END FUNCTION predic
+ END INTERFACE
+ INTERFACE
+ FUNCTION probks(alam)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: alam
+ REAL(SP) :: probks
+ END FUNCTION probks
+ END INTERFACE
+ INTERFACE psdes
+ SUBROUTINE psdes_s(lword,rword)
+ USE nrtype
+ INTEGER(I4B), INTENT(INOUT) :: lword,rword
+ END SUBROUTINE psdes_s
+!BL
+ SUBROUTINE psdes_v(lword,rword)
+ USE nrtype
+ INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword
+ END SUBROUTINE psdes_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pwt(a,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE pwt
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pwtset(n)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ END SUBROUTINE pwtset
+ END INTERFACE
+ INTERFACE pythag
+!BL
+ FUNCTION pythag_sp(a,b)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP) :: pythag_sp
+ END FUNCTION pythag_sp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE pzextr(iest,xest,yest,yz,dy)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: iest
+ REAL(SP), INTENT(IN) :: xest
+ REAL(SP), DIMENSION(:), INTENT(IN) :: yest
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy
+ END SUBROUTINE pzextr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE qrdcmp(a,c,d,sing)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d
+ LOGICAL(LGT), INTENT(OUT) :: sing
+ END SUBROUTINE qrdcmp
+ END INTERFACE
+ INTERFACE
+ FUNCTION qromb(func,a,b)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP) :: qromb
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION qromb
+ END INTERFACE
+ INTERFACE
+ FUNCTION qromo(func,a,b,choose)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP) :: qromo
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE choose(funk,aa,bb,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: aa,bb
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION funk(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: funk
+ END FUNCTION funk
+ END INTERFACE
+ END SUBROUTINE choose
+ END INTERFACE
+ END FUNCTION qromo
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE qroot(p,b,c,eps)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: p
+ REAL(SP), INTENT(INOUT) :: b,c
+ REAL(SP), INTENT(IN) :: eps
+ END SUBROUTINE qroot
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE qrsolv(a,c,d,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ REAL(SP), DIMENSION(:), INTENT(IN) :: c,d
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
+ END SUBROUTINE qrsolv
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE qrupdt(r,qt,u,v)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: u
+ REAL(SP), DIMENSION(:), INTENT(IN) :: v
+ END SUBROUTINE qrupdt
+ END INTERFACE
+ INTERFACE
+ FUNCTION qsimp(func,a,b)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP) :: qsimp
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION qsimp
+ END INTERFACE
+ INTERFACE
+ FUNCTION qtrap(func,a,b)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP) :: qtrap
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION qtrap
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy
+ REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
+ END SUBROUTINE quadct
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE quadmx(a)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a
+ END SUBROUTINE quadmx
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE quadvl(x,y,fa,fb,fc,fd)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y
+ REAL(SP), INTENT(OUT) :: fa,fb,fc,fd
+ END SUBROUTINE quadvl
+ END INTERFACE
+ INTERFACE
+ FUNCTION ran(idum)
+ INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum
+ REAL :: ran
+ END FUNCTION ran
+ END INTERFACE
+ INTERFACE ran0
+ SUBROUTINE ran0_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE ran0_s
+!BL
+ SUBROUTINE ran0_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE ran0_v
+ END INTERFACE
+ INTERFACE ran1
+ SUBROUTINE ran1_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE ran1_s
+!BL
+ SUBROUTINE ran1_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE ran1_v
+ END INTERFACE
+ INTERFACE ran2
+ SUBROUTINE ran2_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE ran2_s
+!BL
+ SUBROUTINE ran2_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE ran2_v
+ END INTERFACE
+ INTERFACE ran3
+ SUBROUTINE ran3_s(harvest)
+ USE nrtype
+ REAL(SP), INTENT(OUT) :: harvest
+ END SUBROUTINE ran3_s
+!BL
+ SUBROUTINE ran3_v(harvest)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest
+ END SUBROUTINE ran3_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ratint(xa,ya,x,y,dy)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: y,dy
+ END SUBROUTINE ratint
+ END INTERFACE
+ INTERFACE rc
+ FUNCTION rc_s(x,y)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y
+ REAL(SP) :: rc_s
+ END FUNCTION rc_s
+!BL
+ FUNCTION rc_v(x,y)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), DIMENSION(size(x)) :: rc_v
+ END FUNCTION rc_v
+ END INTERFACE
+ INTERFACE rd
+ FUNCTION rd_s(x,y,z)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y,z
+ REAL(SP) :: rd_s
+ END FUNCTION rd_s
+!BL
+ FUNCTION rd_v(x,y,z)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z
+ REAL(SP), DIMENSION(size(x)) :: rd_v
+ END FUNCTION rd_v
+ END INTERFACE
+ INTERFACE realft
+!BL
+ SUBROUTINE realft_sp(data,isign,zdata)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: data
+ INTEGER(I4B), INTENT(IN) :: isign
+ COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata
+ END SUBROUTINE realft_sp
+ END INTERFACE
+ INTERFACE
+ RECURSIVE FUNCTION recur1(a,b) RESULT(u)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(size(a)) :: u
+ END FUNCTION recur1
+ END INTERFACE
+ INTERFACE
+ FUNCTION recur2(a,b,c)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c
+ REAL(SP), DIMENSION(size(a)) :: recur2
+ END FUNCTION recur2
+ END INTERFACE
+ INTERFACE rf
+ FUNCTION rf_s(x,y,z)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y,z
+ REAL(SP) :: rf_s
+ END FUNCTION rf_s
+!BL
+ FUNCTION rf_v(x,y,z)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z
+ REAL(SP), DIMENSION(size(x)) :: rf_v
+ END FUNCTION rf_v
+ END INTERFACE
+ INTERFACE rj
+ FUNCTION rj_s(x,y,z,p)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x,y,z,p
+ REAL(SP) :: rj_s
+ END FUNCTION rj_s
+!BL
+ FUNCTION rj_v(x,y,z,p)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p
+ REAL(SP), DIMENSION(size(x)) :: rj_v
+ END FUNCTION rj_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rk4(y,dydx,x,h,yout,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
+ REAL(SP), INTENT(IN) :: x,h
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE rk4
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx
+ REAL(SP), INTENT(IN) :: x,h
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE rkck
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: vstart
+ REAL(SP), INTENT(IN) :: x1,x2
+ INTEGER(I4B), INTENT(IN) :: nstep
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE rkdumb
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
+ REAL(SP), INTENT(INOUT) :: x
+ REAL(SP), INTENT(IN) :: htry,eps
+ REAL(SP), INTENT(OUT) :: hdid,hnext
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE rkqs
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rlft2(data,spec,speq,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec
+ COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE rlft2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rlft3(data,spec,speq,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE rlft3
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rotate(r,qt,i,a,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt
+ INTEGER(I4B), INTENT(IN) :: i
+ REAL(SP), INTENT(IN) :: a,b
+ END SUBROUTINE rotate
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rsolv(a,d,b)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ REAL(SP), DIMENSION(:), INTENT(IN) :: d
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
+ END SUBROUTINE rsolv
+ END INTERFACE
+ INTERFACE
+ FUNCTION rtbis(func,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: rtbis
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION rtbis
+ END INTERFACE
+ INTERFACE
+ FUNCTION rtflsp(func,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: rtflsp
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION rtflsp
+ END INTERFACE
+ INTERFACE
+ FUNCTION rtnewt(funcd,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: rtnewt
+ INTERFACE
+ SUBROUTINE funcd(x,fval,fderiv)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: fval,fderiv
+ END SUBROUTINE funcd
+ END INTERFACE
+ END FUNCTION rtnewt
+ END INTERFACE
+ INTERFACE
+ FUNCTION rtsafe(funcd,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: rtsafe
+ INTERFACE
+ SUBROUTINE funcd(x,fval,fderiv)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: fval,fderiv
+ END SUBROUTINE funcd
+ END INTERFACE
+ END FUNCTION rtsafe
+ END INTERFACE
+ INTERFACE
+ FUNCTION rtsec(func,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: rtsec
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION rtsec
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE rzextr(iest,xest,yest,yz,dy)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: iest
+ REAL(SP), INTENT(IN) :: xest
+ REAL(SP), DIMENSION(:), INTENT(IN) :: yest
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy
+ END SUBROUTINE rzextr
+ END INTERFACE
+ INTERFACE
+ FUNCTION savgol(nl,nrr,ld,m)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m
+ REAL(SP), DIMENSION(nl+nrr+1) :: savgol
+ END FUNCTION savgol
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE scrsho(func)
+ USE nrtype
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE scrsho
+ END INTERFACE
+ INTERFACE
+ FUNCTION select(k,arr)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: k
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ REAL(SP) :: select
+ END FUNCTION select
+ END INTERFACE
+ INTERFACE
+ FUNCTION select_bypack(k,arr)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: k
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ REAL(SP) :: select_bypack
+ END FUNCTION select_bypack
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE select_heap(arr,heap)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: heap
+ END SUBROUTINE select_heap
+ END INTERFACE
+ INTERFACE
+ FUNCTION select_inplace(k,arr)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: k
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ REAL(SP) :: select_inplace
+ END FUNCTION select_inplace
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: m1,m2,m3
+ INTEGER(I4B), INTENT(OUT) :: icase
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv
+ END SUBROUTINE simplx
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: xs,htot
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy
+ INTEGER(I4B), INTENT(IN) :: nstep
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE simpr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sinft(y)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ END SUBROUTINE sinft
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sncndn(uu,emmc,sn,cn,dn)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: uu,emmc
+ REAL(SP), INTENT(OUT) :: sn,cn,dn
+ END SUBROUTINE sncndn
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sobseq(x,init)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: init
+ END SUBROUTINE sobseq
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: itmax,nb
+ REAL(SP), INTENT(IN) :: conv,slowc
+ REAL(SP), DIMENSION(:), INTENT(IN) :: scalv
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y
+ END SUBROUTINE solvde
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort2(arr,slave)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave
+ END SUBROUTINE sort2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort3(arr,slave1,slave2)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2
+ END SUBROUTINE sort3
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_bypack(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_bypack
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_byreshape(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_byreshape
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_heap(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_heap
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_pick(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_pick
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_radix(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_radix
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sort_shell(arr)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr
+ END SUBROUTINE sort_shell
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE spctrm(p,k,ovrlap,unit,n_window)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: p
+ INTEGER(I4B), INTENT(IN) :: k
+ LOGICAL(LGT), INTENT(IN) :: ovrlap
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit
+ END SUBROUTINE spctrm
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs
+ END SUBROUTINE spear
+ END INTERFACE
+ INTERFACE sphbes
+ SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp
+ END SUBROUTINE sphbes_s
+!BL
+ SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp
+ END SUBROUTINE sphbes_v
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE splie2(x1a,x2a,ya,y2a)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a
+ END SUBROUTINE splie2
+ END INTERFACE
+ INTERFACE
+ FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a
+ REAL(SP), INTENT(IN) :: x1,x2
+ REAL(SP) :: splin2
+ END FUNCTION splin2
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE spline(x,y,yp1,ypn,y2)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y
+ REAL(SP), INTENT(IN) :: yp1,ypn
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: y2
+ END SUBROUTINE spline
+ END INTERFACE
+ INTERFACE
+ FUNCTION splint(xa,ya,y2a,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: splint
+ END FUNCTION splint
+ END INTERFACE
+ INTERFACE sprsax
+ SUBROUTINE sprsax_dp(sa,x,b)
+ USE nrtype
+ TYPE(sprs2_dp), INTENT(IN) :: sa
+ REAL(DP), DIMENSION (:), INTENT(IN) :: x
+ REAL(DP), DIMENSION (:), INTENT(OUT) :: b
+ END SUBROUTINE sprsax_dp
+!BL
+ SUBROUTINE sprsax_sp(sa,x,b)
+ USE nrtype
+ TYPE(sprs2_sp), INTENT(IN) :: sa
+ REAL(SP), DIMENSION (:), INTENT(IN) :: x
+ REAL(SP), DIMENSION (:), INTENT(OUT) :: b
+ END SUBROUTINE sprsax_sp
+ END INTERFACE
+ INTERFACE sprsdiag
+ SUBROUTINE sprsdiag_dp(sa,b)
+ USE nrtype
+ TYPE(sprs2_dp), INTENT(IN) :: sa
+ REAL(DP), DIMENSION(:), INTENT(OUT) :: b
+ END SUBROUTINE sprsdiag_dp
+!BL
+ SUBROUTINE sprsdiag_sp(sa,b)
+ USE nrtype
+ TYPE(sprs2_sp), INTENT(IN) :: sa
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: b
+ END SUBROUTINE sprsdiag_sp
+ END INTERFACE
+ INTERFACE sprsin
+ SUBROUTINE sprsin_sp(a,thresh,sa)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
+ REAL(SP), INTENT(IN) :: thresh
+ TYPE(sprs2_sp), INTENT(OUT) :: sa
+ END SUBROUTINE sprsin_sp
+!BL
+ SUBROUTINE sprsin_dp(a,thresh,sa)
+ USE nrtype
+ REAL(DP), DIMENSION(:,:), INTENT(IN) :: a
+ REAL(DP), INTENT(IN) :: thresh
+ TYPE(sprs2_dp), INTENT(OUT) :: sa
+ END SUBROUTINE sprsin_dp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE sprstp(sa)
+ USE nrtype
+ TYPE(sprs2_sp), INTENT(INOUT) :: sa
+ END SUBROUTINE sprstp
+ END INTERFACE
+ INTERFACE sprstx
+ SUBROUTINE sprstx_dp(sa,x,b)
+ USE nrtype
+ TYPE(sprs2_dp), INTENT(IN) :: sa
+ REAL(DP), DIMENSION (:), INTENT(IN) :: x
+ REAL(DP), DIMENSION (:), INTENT(OUT) :: b
+ END SUBROUTINE sprstx_dp
+!BL
+ SUBROUTINE sprstx_sp(sa,x,b)
+ USE nrtype
+ TYPE(sprs2_sp), INTENT(IN) :: sa
+ REAL(SP), DIMENSION (:), INTENT(IN) :: x
+ REAL(SP), DIMENSION (:), INTENT(OUT) :: b
+ END SUBROUTINE sprstx_sp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
+ REAL(SP), INTENT(IN) :: htry,eps
+ REAL(SP), INTENT(INOUT) :: x
+ REAL(SP), INTENT(OUT) :: hdid,hnext
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE stifbs
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: y
+ REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal
+ REAL(SP), INTENT(INOUT) :: x
+ REAL(SP), INTENT(IN) :: htry,eps
+ REAL(SP), INTENT(OUT) :: hdid,hnext
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE stiff
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y
+ REAL(SP), INTENT(IN) :: xs,htot
+ INTEGER(I4B), INTENT(IN) :: nstep
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: yout
+ INTERFACE
+ SUBROUTINE derivs(x,y,dydx)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: y
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx
+ END SUBROUTINE derivs
+ END INTERFACE
+ END SUBROUTINE stoerm
+ END INTERFACE
+ INTERFACE svbksb
+!BL
+ SUBROUTINE svbksb_sp(u,w,v,b,x)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v
+ REAL(SP), DIMENSION(:), INTENT(IN) :: w,b
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: x
+ END SUBROUTINE svbksb_sp
+ END INTERFACE
+ INTERFACE svdcmp
+!BL
+ SUBROUTINE svdcmp_sp(a,w,v)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: w
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
+ END SUBROUTINE svdcmp_sp
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v
+ REAL(SP), INTENT(OUT) :: chisq
+ INTERFACE
+ FUNCTION funcs(x,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: funcs
+ END FUNCTION funcs
+ END INTERFACE
+ END SUBROUTINE svdfit
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE svdvar(v,w,cvm)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: v
+ REAL(SP), DIMENSION(:), INTENT(IN) :: w
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm
+ END SUBROUTINE svdvar
+ END INTERFACE
+ INTERFACE
+ FUNCTION toeplz(r,y)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: r,y
+ REAL(SP), DIMENSION(size(y)) :: toeplz
+ END FUNCTION toeplz
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE tptest(data1,data2,t,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ REAL(SP), INTENT(OUT) :: t,prob
+ END SUBROUTINE tptest
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE tqli(d,e,z)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e
+ REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z
+ END SUBROUTINE tqli
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE trapzd(func,a,b,s,n)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: a,b
+ REAL(SP), INTENT(INOUT) :: s
+ INTEGER(I4B), INTENT(IN) :: n
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: x
+ REAL(SP), DIMENSION(size(x)) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE trapzd
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE tred2(a,d,e,novectors)
+ USE nrtype
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors
+ END SUBROUTINE tred2
+ END INTERFACE
+! On a purely serial machine, for greater efficiency, remove
+! the generic name tridag from the following interface,
+! and put it on the next one after that.
+ INTERFACE tridag
+ RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: u
+ END SUBROUTINE tridag_par
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE tridag_ser(a,b,c,r,u)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: u
+ END SUBROUTINE tridag_ser
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE ttest(data1,data2,t,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ REAL(SP), INTENT(OUT) :: t,prob
+ END SUBROUTINE ttest
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE tutest(data1,data2,t,prob)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ REAL(SP), INTENT(OUT) :: t,prob
+ END SUBROUTINE tutest
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE twofft(data1,data2,fft1,fft2)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
+ COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2
+ END SUBROUTINE twofft
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: region
+ INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn
+ REAL(SP), INTENT(OUT) :: tgral,sd,chi2a
+ INTERFACE
+ FUNCTION func(pt,wgt)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: pt
+ REAL(SP), INTENT(IN) :: wgt
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE vegas
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE voltra(t0,h,t,f,g,ak)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: t0,h
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: t
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f
+ INTERFACE
+ FUNCTION g(t)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: t
+ REAL(SP), DIMENSION(:), POINTER :: g
+ END FUNCTION g
+!BL
+ FUNCTION ak(t,s)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: t,s
+ REAL(SP), DIMENSION(:,:), POINTER :: ak
+ END FUNCTION ak
+ END INTERFACE
+ END SUBROUTINE voltra
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE wt1(a,isign,wtstep)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTERFACE
+ SUBROUTINE wtstep(a,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE wtstep
+ END INTERFACE
+ END SUBROUTINE wt1
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE wtn(a,nn,isign,wtstep)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTERFACE
+ SUBROUTINE wtstep(a,isign)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
+ INTEGER(I4B), INTENT(IN) :: isign
+ END SUBROUTINE wtstep
+ END INTERFACE
+ END SUBROUTINE wtn
+ END INTERFACE
+ INTERFACE
+ FUNCTION wwghts(n,h,kermom)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), INTENT(IN) :: h
+ REAL(SP), DIMENSION(n) :: wwghts
+ END FUNCTION wwghts
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE zbrac(func,x1,x2,succes)
+ USE nrtype
+ REAL(SP), INTENT(INOUT) :: x1,x2
+ LOGICAL(LGT), INTENT(OUT) :: succes
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE zbrac
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb)
+ USE nrtype
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), INTENT(OUT) :: nb
+ REAL(SP), INTENT(IN) :: x1,x2
+ REAL(SP), DIMENSION(:), POINTER :: xb1,xb2
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END SUBROUTINE zbrak
+ END INTERFACE
+ INTERFACE
+ FUNCTION zbrent(func,x1,x2,tol)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,tol
+ REAL(SP) :: zbrent
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION zbrent
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE zrhqr(a,rtr,rti)
+ USE nrtype
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti
+ END SUBROUTINE zrhqr
+ END INTERFACE
+ INTERFACE
+ FUNCTION zriddr(func,x1,x2,xacc)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x1,x2,xacc
+ REAL(SP) :: zriddr
+ INTERFACE
+ FUNCTION func(x)
+ USE nrtype
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP) :: func
+ END FUNCTION func
+ END INTERFACE
+ END FUNCTION zriddr
+ END INTERFACE
+ INTERFACE
+ SUBROUTINE zroots(a,roots,polish)
+ USE nrtype
+ COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
+ COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots
+ LOGICAL(LGT), INTENT(IN) :: polish
+ END SUBROUTINE zroots
+ END INTERFACE
+END MODULE nr
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/nrtype.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/nrtype.f90
new file mode 100644
index 0000000000000000000000000000000000000000..083ed64d122ae04384f84576ace0e6e981b14ef7
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/nrtype.f90
@@ -0,0 +1,114 @@
+MODULE nrtype
+ INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
+ INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
+ INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
+ INTEGER, PARAMETER :: SP = KIND(1.0D0)
+ INTEGER, PARAMETER :: DP = KIND(1.0D0)
+ INTEGER, PARAMETER :: SPC = KIND((1.0D0,1.0D0))
+ INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
+ INTEGER, PARAMETER :: LGT = KIND(.true.)
+! REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp
+ REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp
+ REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp
+ REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp
+ REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp
+ REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp
+ REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp
+ REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp
+ TYPE sprs2_sp
+ INTEGER(I4B) :: n,len
+ REAL(SP), DIMENSION(:), POINTER :: val
+ INTEGER(I4B), DIMENSION(:), POINTER :: irow
+ INTEGER(I4B), DIMENSION(:), POINTER :: jcol
+ END TYPE sprs2_sp
+ TYPE sprs2_dp
+ INTEGER(I4B) :: n,len
+ REAL(DP), DIMENSION(:), POINTER :: val
+ INTEGER(I4B), DIMENSION(:), POINTER :: irow
+ INTEGER(I4B), DIMENSION(:), POINTER :: jcol
+ END TYPE sprs2_dp
+END MODULE nrtype
+
+!About Converting to Higher Precision
+!=====================================
+
+!!$You might hope that changing all the Numerical Recipes routines from single
+!!$precision to double precision would be as simple as redefining the values of SP and
+!!$DP in nrtype. Well . . . not quite.
+!!$Converting algorithms to a higher precision is not a purely mechanical task
+!!$because of the distinction between âroundoff errorâ and âtruncation error.â (Please
+!!$see Volume 1, §1.2, if you are not familiar with these concepts.) While increasing the
+!!$precision implied by the kind values SP and DP will indeed reduce a routineâs roundoff
+!!$error, it will not reduce any truncation error that may be intrinsic to the algorithm.
+!!$Sometimes, a routine contains âaccuracy parametersâ that can be adjusted to reduce
+!!$the truncation error to the new, desired level. In other cases, however, the truncation
+!!$error cannot be so easily reduced; then, a whole new algorithm is needed. Clearly
+!!$such new algorithms are beyond the scope of a simple mechanical âconversion.â
+!!$If, despite these cautionary words, you want to proceed with converting some
+!!$routines to a higher precision, here are some hints:
+!!$If your machine has a kind type that is distinct from, and has equal or greater
+!!$precision than, the kind type that we use for DP, then, in nrtype, you can simply
+!!$redefine DP to this new highest precision and redefine SP to what was previously
+!!$DP. For example, DEC machines usually have a âquadruple precisionâ real type
+!!$available, which can be used in this way. You should not need to make any further
+!!$edits of nrtype or nrutil.
+!!$If, on the other hand, the kind type that we already use for DP is the highest
+!!$precision available, then you must leave DP defined as it is, and redefine SP in nrtype
+!!$to be this same kind type. Now, however, you will also have to edit nrutil, because
+!!$some overloaded routines that were previously distinguishable (by the different kind
+!!$types) will now be seen by the compiler as indistinguishable â and it will object
+!!$strenuously. Simply delete all the â dpâ function names from the list of overloaded
+!!$procedures (i.e., from the MODULE PROCEDURE statements). Note that it is not
+!!$necessary to delete the routines from the MODULE itself. Similarly, in the interface
+!!$file nr.f90 you must delete the â dpâ interfaces, except for the sprs... routines.
+!!$(Since they have TYPE(sprs2 dp) or TYPE(sprs2 sp), they are treated as distinct
+!!$even though they have functionally equivalent kind types.)
+!!$Finally, the following table gives some suggestions for changing the accuracy
+!!$parameters, or constants, in some of the routines. Please note that this table is not
+!!$necessarily complete, and that higher-precision performance is not guaranteed for all
+!!$the routines, even if you make all the changes indicated. The above edits, and these
+!!$suggestions, do, however, work in the majority of cases.
+!!$
+!!$
+!!$
+!!$
+!!$
+!!$In routine... change... to...
+!!$beschb NUSE1=5,NUSE2=5 NUSE1=7,NUSE2=8
+!!$bessi IACC=40 IACC=200
+!!$bessik EPS=1.0e-10 dp EPS=epsilon(x)
+!!$bessj IACC=40 IACC=160
+!!$bessjy EPS=1.0e-10 dp EPS=epsilon(x)
+!!$broydn TOLF=1.0e-4 sp TOLF=1.0e-8 sp
+!!$TOLMIN=1.0e-6 sp TOLMIN=1.0e-12 sp
+!!$fdjac EPS=1.0e-4 sp EPS=1.0e-8 sp
+!!$frprmn EPS=1.0e-10 sp EPS=1.0e-18 sp
+!!$gauher EPS=3.0e-13 dp EPS=1.0e-14 dp
+!!$gaujac EPS=3.0e-14 dp EPS=1.0e-14 dp
+!!$gaulag EPS=3.0e-13 dp EPS=1.0e-14 dp
+!!$gauleg EPS=3.0e-14 dp EPS=1.0e-14 dp
+!!$hypgeo EPS=1.0e-6 sp EPS=1.0e-14 sp
+!!$linmin TOL=1.0e-4 sp TOL=1.0e-8 sp
+!!$newt TOLF=1.0e-4 sp TOLF=1.0e-8 sp
+!!$TOLMIN=1.0e-6 sp TOLMIN=1.0e-12 sp
+!!$probks EPS1=0.001 sp EPS1=1.0e-6 sp
+!!$EPS2=1.0e-8 sp EPS2=1.0e-16 sp
+!!$qromb EPS=1.0e-6 sp EPS=1.0e-10 sp
+!!$qromo EPS=1.0e-6 sp EPS=1.0e-10 sp
+!!$qroot TINY=1.0e-6 sp TINY=1.0e-14 sp
+!!$qsimp EPS=1.0e-6 sp EPS=1.0e-10 sp
+!!$qtrap EPS=1.0e-6 sp EPS=1.0e-10 sp
+!!$rc ERRTOL=0.04 sp ERRTOL=0.0012 sp
+!!$rd ERRTOL=0.05 sp ERRTOL=0.0015 sp
+!!$rf ERRTOL=0.08 sp ERRTOL=0.0025 sp
+!!$rj ERRTOL=0.05 sp ERRTOL=0.0015 sp
+!!$sfroid conv=5.0e-6 sp conv=1.0e-14 sp
+!!$shoot EPS=1.0e-6 sp EPS=1.0e-14 sp
+!!$shootf EPS=1.0e-6 sp EPS=1.0e-14 sp
+!!$simplx EPS=1.0e-6 sp EPS=1.0e-14 sp
+!!$sncndn CA=0.0003 sp CA=1.0e-8 sp
+!!$sor EPS=1.0e-5 dp EPS=1.0e-13 dp
+!!$sphfpt DXX=1.0e-4 sp DXX=1.0e-8 sp
+!!$sphoot dx=1.0e-4 sp dx=1.0e-8 sp
+!!$svdfit TOL=1.0e-5 sp TOL=1.0e-13 sp
+!!$zroots EPS=1.0e-6 sp EPS=1.0e-14 sp
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/nrutil.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/nrutil.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f5b6a296fcce59302753468ec5be370acd43f84f
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/nrutil.f90
@@ -0,0 +1,1154 @@
+MODULE nrutil
+ USE nrtype
+ IMPLICIT NONE
+ INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8
+ INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2
+ INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16
+ INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8
+ INTEGER(I4B), PARAMETER :: NPAR_POLY=8
+ INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8
+ INTERFACE array_copy
+ MODULE PROCEDURE array_copy_r,array_copy_i
+ END INTERFACE
+ INTERFACE swap
+ MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, &
+ swap_cv,swap_cm, &
+ masked_swap_rs,masked_swap_rv,masked_swap_rm
+ END INTERFACE
+ INTERFACE reallocate
+ MODULE PROCEDURE reallocate_rv,reallocate_rm,&
+ reallocate_iv,reallocate_im,reallocate_hv
+ END INTERFACE
+ INTERFACE imaxloc
+ MODULE PROCEDURE imaxloc_r,imaxloc_i
+ END INTERFACE
+ INTERFACE assert
+ MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
+ END INTERFACE
+ INTERFACE assert_eq
+ MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
+ END INTERFACE
+ INTERFACE arth
+ MODULE PROCEDURE arth_r, arth_i
+ END INTERFACE
+ INTERFACE geop
+ MODULE PROCEDURE geop_r, geop_i, geop_c
+ END INTERFACE
+ INTERFACE cumsum
+ MODULE PROCEDURE cumsum_r,cumsum_i
+ END INTERFACE
+ INTERFACE poly
+ MODULE PROCEDURE poly_rr,poly_rrv,&
+ poly_rc,poly_cc,poly_msk_rrv
+ END INTERFACE
+ INTERFACE poly_term
+ MODULE PROCEDURE poly_term_rr,poly_term_cc
+ END INTERFACE
+ INTERFACE outerprod
+ MODULE PROCEDURE outerprod_r
+ END INTERFACE
+ INTERFACE outerdiff
+ MODULE PROCEDURE outerdiff_r,outerdiff_i
+ END INTERFACE
+ INTERFACE scatter_add
+ MODULE PROCEDURE scatter_add_r
+ END INTERFACE
+ INTERFACE scatter_max
+ MODULE PROCEDURE scatter_max_r
+ END INTERFACE
+ INTERFACE diagadd
+ MODULE PROCEDURE diagadd_rv,diagadd_r
+ END INTERFACE
+ INTERFACE diagmult
+ MODULE PROCEDURE diagmult_rv,diagmult_r
+ END INTERFACE
+ INTERFACE get_diag
+ MODULE PROCEDURE get_diag_rv
+ END INTERFACE
+ INTERFACE put_diag
+ MODULE PROCEDURE put_diag_rv, put_diag_r
+ END INTERFACE
+CONTAINS
+!BL
+ SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: src
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
+ INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
+ n_copied=min(size(src),size(dest))
+ n_not_copied=size(src)-n_copied
+ dest(1:n_copied)=src(1:n_copied)
+ END SUBROUTINE array_copy_r
+!BL
+ SUBROUTINE array_copy_d(src,dest,n_copied,n_not_copied)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: src
+ REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
+ INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
+ n_copied=min(size(src),size(dest))
+ n_not_copied=size(src)-n_copied
+ dest(1:n_copied)=src(1:n_copied)
+ END SUBROUTINE array_copy_d
+!BL
+ SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied)
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src
+ INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest
+ INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied
+ n_copied=min(size(src),size(dest))
+ n_not_copied=size(src)-n_copied
+ dest(1:n_copied)=src(1:n_copied)
+ END SUBROUTINE array_copy_i
+!BL
+!BL
+ SUBROUTINE swap_i(a,b)
+ INTEGER(I4B), INTENT(INOUT) :: a,b
+ INTEGER(I4B) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_i
+!BL
+ SUBROUTINE swap_r(a,b)
+ REAL(SP), INTENT(INOUT) :: a,b
+ REAL(SP) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_r
+!BL
+ SUBROUTINE swap_rv(a,b)
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
+ REAL(SP), DIMENSION(SIZE(a)) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_rv
+!BL
+ SUBROUTINE swap_c(a,b)
+ COMPLEX(SPC), INTENT(INOUT) :: a,b
+ COMPLEX(SPC) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_c
+!BL
+ SUBROUTINE swap_cv(a,b)
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b
+ COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_cv
+!BL
+ SUBROUTINE swap_cm(a,b)
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b
+ COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_cm
+!BL
+ SUBROUTINE swap_z(a,b)
+ COMPLEX(DPC), INTENT(INOUT) :: a,b
+ COMPLEX(DPC) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_z
+!BL
+ SUBROUTINE swap_zv(a,b)
+ COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: a,b
+ COMPLEX(DPC), DIMENSION(SIZE(a)) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_zv
+!BL
+ SUBROUTINE swap_zm(a,b)
+ COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: a,b
+ COMPLEX(DPC), DIMENSION(size(a,1),size(a,2)) :: dum
+ dum=a
+ a=b
+ b=dum
+ END SUBROUTINE swap_zm
+!BL
+ SUBROUTINE masked_swap_rs(a,b,mask)
+ REAL(SP), INTENT(INOUT) :: a,b
+ LOGICAL(LGT), INTENT(IN) :: mask
+ REAL(SP) :: swp
+ if (mask) then
+ swp=a
+ a=b
+ b=swp
+ end if
+ END SUBROUTINE masked_swap_rs
+!BL
+ SUBROUTINE masked_swap_rv(a,b,mask)
+ REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
+ REAL(SP), DIMENSION(size(a)) :: swp
+ where (mask)
+ swp=a
+ a=b
+ b=swp
+ end where
+ END SUBROUTINE masked_swap_rv
+!BL
+ SUBROUTINE masked_swap_rm(a,b,mask)
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b
+ LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask
+ REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp
+ where (mask)
+ swp=a
+ a=b
+ b=swp
+ end where
+ END SUBROUTINE masked_swap_rm
+!BL
+!BL
+ FUNCTION reallocate_rv(p,n)
+ REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B) :: nold,ierr
+ allocate(reallocate_rv(n),stat=ierr)
+ if (ierr /= 0) call &
+ nrerror('reallocate_rv: problem in attempt to allocate memory')
+ if (.not. associated(p)) RETURN
+ nold=size(p)
+ reallocate_rv(1:min(nold,n))=p(1:min(nold,n))
+ deallocate(p)
+ END FUNCTION reallocate_rv
+!BL
+ FUNCTION reallocate_iv(p,n)
+ INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B) :: nold,ierr
+ allocate(reallocate_iv(n),stat=ierr)
+ if (ierr /= 0) call &
+ nrerror('reallocate_iv: problem in attempt to allocate memory')
+ if (.not. associated(p)) RETURN
+ nold=size(p)
+ reallocate_iv(1:min(nold,n))=p(1:min(nold,n))
+ deallocate(p)
+ END FUNCTION reallocate_iv
+!BL
+ FUNCTION reallocate_hv(p,n)
+ CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B) :: nold,ierr
+ allocate(reallocate_hv(n),stat=ierr)
+ if (ierr /= 0) call &
+ nrerror('reallocate_hv: problem in attempt to allocate memory')
+ if (.not. associated(p)) RETURN
+ nold=size(p)
+ reallocate_hv(1:min(nold,n))=p(1:min(nold,n))
+ deallocate(p)
+ END FUNCTION reallocate_hv
+!BL
+ FUNCTION reallocate_rm(p,n,m)
+ REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm
+ INTEGER(I4B), INTENT(IN) :: n,m
+ INTEGER(I4B) :: nold,mold,ierr
+ allocate(reallocate_rm(n,m),stat=ierr)
+ if (ierr /= 0) call &
+ nrerror('reallocate_rm: problem in attempt to allocate memory')
+ if (.not. associated(p)) RETURN
+ nold=size(p,1)
+ mold=size(p,2)
+ reallocate_rm(1:min(nold,n),1:min(mold,m))=&
+ p(1:min(nold,n),1:min(mold,m))
+ deallocate(p)
+ END FUNCTION reallocate_rm
+!BL
+ FUNCTION reallocate_im(p,n,m)
+ INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im
+ INTEGER(I4B), INTENT(IN) :: n,m
+ INTEGER(I4B) :: nold,mold,ierr
+ allocate(reallocate_im(n,m),stat=ierr)
+ if (ierr /= 0) call &
+ nrerror('reallocate_im: problem in attempt to allocate memory')
+ if (.not. associated(p)) RETURN
+ nold=size(p,1)
+ mold=size(p,2)
+ reallocate_im(1:min(nold,n),1:min(mold,m))=&
+ p(1:min(nold,n),1:min(mold,m))
+ deallocate(p)
+ END FUNCTION reallocate_im
+!BL
+ FUNCTION ifirstloc(mask)
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
+ INTEGER(I4B) :: ifirstloc
+ INTEGER(I4B), DIMENSION(1) :: loc
+ loc=maxloc(merge(1,0,mask))
+ ifirstloc=loc(1)
+ if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1
+ END FUNCTION ifirstloc
+!BL
+ FUNCTION imaxloc_r(arr)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ INTEGER(I4B) :: imaxloc_r
+ INTEGER(I4B), DIMENSION(1) :: imax
+ imax=maxloc(arr(:))
+ imaxloc_r=imax(1)
+ END FUNCTION imaxloc_r
+!BL
+ FUNCTION imaxloc_i(iarr)
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr
+ INTEGER(I4B), DIMENSION(1) :: imax
+ INTEGER(I4B) :: imaxloc_i
+ imax=maxloc(iarr(:))
+ imaxloc_i=imax(1)
+ END FUNCTION imaxloc_i
+!BL
+ FUNCTION iminloc(arr)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ INTEGER(I4B), DIMENSION(1) :: imin
+ INTEGER(I4B) :: iminloc
+ imin=minloc(arr(:))
+ iminloc=imin(1)
+ END FUNCTION iminloc
+!BL
+ SUBROUTINE assert1(n1,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ LOGICAL, INTENT(IN) :: n1
+ if (.not. n1) then
+ write (*,*) 'nrerror: an assertion failed with this tag:', &
+ string
+ STOP 'program terminated by assert1'
+ end if
+ END SUBROUTINE assert1
+!BL
+ SUBROUTINE assert2(n1,n2,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ LOGICAL, INTENT(IN) :: n1,n2
+ if (.not. (n1 .and. n2)) then
+ write (*,*) 'nrerror: an assertion failed with this tag:', &
+ string
+ STOP 'program terminated by assert2'
+ end if
+ END SUBROUTINE assert2
+!BL
+ SUBROUTINE assert3(n1,n2,n3,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ LOGICAL, INTENT(IN) :: n1,n2,n3
+ if (.not. (n1 .and. n2 .and. n3)) then
+ write (*,*) 'nrerror: an assertion failed with this tag:', &
+ string
+ STOP 'program terminated by assert3'
+ end if
+ END SUBROUTINE assert3
+!BL
+ SUBROUTINE assert4(n1,n2,n3,n4,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ LOGICAL, INTENT(IN) :: n1,n2,n3,n4
+ if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
+ write (*,*) 'nrerror: an assertion failed with this tag:', &
+ string
+ STOP 'program terminated by assert4'
+ end if
+ END SUBROUTINE assert4
+!BL
+ SUBROUTINE assert_v(n,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ LOGICAL, DIMENSION(:), INTENT(IN) :: n
+ if (.not. all(n)) then
+ write (*,*) 'nrerror: an assertion failed with this tag:', &
+ string
+ STOP 'program terminated by assert_v'
+ end if
+ END SUBROUTINE assert_v
+!BL
+ FUNCTION assert_eq2(n1,n2,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ INTEGER, INTENT(IN) :: n1,n2
+ INTEGER :: assert_eq2
+ if (n1 == n2) then
+ assert_eq2=n1
+ else
+ write (*,*) 'nrerror: an assert_eq failed with this tag:', &
+ string
+ STOP 'program terminated by assert_eq2'
+ end if
+ END FUNCTION assert_eq2
+!BL
+ FUNCTION assert_eq3(n1,n2,n3,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ INTEGER, INTENT(IN) :: n1,n2,n3
+ INTEGER :: assert_eq3
+ if (n1 == n2 .and. n2 == n3) then
+ assert_eq3=n1
+ else
+ write (*,*) 'nrerror: an assert_eq failed with this tag:', &
+ string
+ STOP 'program terminated by assert_eq3'
+ end if
+ END FUNCTION assert_eq3
+!BL
+ FUNCTION assert_eq4(n1,n2,n3,n4,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ INTEGER, INTENT(IN) :: n1,n2,n3,n4
+ INTEGER :: assert_eq4
+ if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
+ assert_eq4=n1
+ else
+ write (*,*) 'nrerror: an assert_eq failed with this tag:', &
+ string
+ STOP 'program terminated by assert_eq4'
+ end if
+ END FUNCTION assert_eq4
+!BL
+ FUNCTION assert_eqn(nn,string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ INTEGER, DIMENSION(:), INTENT(IN) :: nn
+ INTEGER :: assert_eqn
+ if (all(nn(2:) == nn(1))) then
+ assert_eqn=nn(1)
+ else
+ write (*,*) 'nrerror: an assert_eq failed with this tag:', &
+ string
+ STOP 'program terminated by assert_eqn'
+ end if
+ END FUNCTION assert_eqn
+!BL
+ SUBROUTINE nrerror(string)
+ CHARACTER(LEN=*), INTENT(IN) :: string
+ write (*,*) 'nrerror: ',string
+ STOP 'program terminated by nrerror'
+ END SUBROUTINE nrerror
+!BL
+ FUNCTION arth_r(first,increment,n)
+ REAL(SP), INTENT(IN) :: first,increment
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: arth_r
+ INTEGER(I4B) :: k,k2
+ REAL(SP) :: temp
+ if (n > 0) arth_r(1)=first
+ if (n <= NPAR_ARTH) then
+ do k=2,n
+ arth_r(k)=arth_r(k-1)+increment
+ end do
+ else
+ do k=2,NPAR2_ARTH
+ arth_r(k)=arth_r(k-1)+increment
+ end do
+ temp=increment*NPAR2_ARTH
+ k=NPAR2_ARTH
+ do
+ if (k >= n) exit
+ k2=k+k
+ arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k))
+ temp=temp+temp
+ k=k2
+ end do
+ end if
+ END FUNCTION arth_r
+!BL
+ FUNCTION arth_d(first,increment,n)
+ REAL(DP), INTENT(IN) :: first,increment
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DP), DIMENSION(n) :: arth_d
+ INTEGER(I4B) :: k,k2
+ REAL(DP) :: temp
+ if (n > 0) arth_d(1)=first
+ if (n <= NPAR_ARTH) then
+ do k=2,n
+ arth_d(k)=arth_d(k-1)+increment
+ end do
+ else
+ do k=2,NPAR2_ARTH
+ arth_d(k)=arth_d(k-1)+increment
+ end do
+ temp=increment*NPAR2_ARTH
+ k=NPAR2_ARTH
+ do
+ if (k >= n) exit
+ k2=k+k
+ arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k))
+ temp=temp+temp
+ k=k2
+ end do
+ end if
+ END FUNCTION arth_d
+!BL
+ FUNCTION arth_i(first,increment,n)
+ INTEGER(I4B), INTENT(IN) :: first,increment,n
+ INTEGER(I4B), DIMENSION(n) :: arth_i
+ INTEGER(I4B) :: k,k2,temp
+ if (n > 0) arth_i(1)=first
+ if (n <= NPAR_ARTH) then
+ do k=2,n
+ arth_i(k)=arth_i(k-1)+increment
+ end do
+ else
+ do k=2,NPAR2_ARTH
+ arth_i(k)=arth_i(k-1)+increment
+ end do
+ temp=increment*NPAR2_ARTH
+ k=NPAR2_ARTH
+ do
+ if (k >= n) exit
+ k2=k+k
+ arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k))
+ temp=temp+temp
+ k=k2
+ end do
+ end if
+ END FUNCTION arth_i
+!BL
+!BL
+ FUNCTION geop_r(first,factor,n)
+ REAL(SP), INTENT(IN) :: first,factor
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(SP), DIMENSION(n) :: geop_r
+ INTEGER(I4B) :: k,k2
+ REAL(SP) :: temp
+ if (n > 0) geop_r(1)=first
+ if (n <= NPAR_GEOP) then
+ do k=2,n
+ geop_r(k)=geop_r(k-1)*factor
+ end do
+ else
+ do k=2,NPAR2_GEOP
+ geop_r(k)=geop_r(k-1)*factor
+ end do
+ temp=factor**NPAR2_GEOP
+ k=NPAR2_GEOP
+ do
+ if (k >= n) exit
+ k2=k+k
+ geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k))
+ temp=temp*temp
+ k=k2
+ end do
+ end if
+ END FUNCTION geop_r
+!BL
+ FUNCTION geop_d(first,factor,n)
+ REAL(DP), INTENT(IN) :: first,factor
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DP), DIMENSION(n) :: geop_d
+ INTEGER(I4B) :: k,k2
+ REAL(DP) :: temp
+ if (n > 0) geop_d(1)=first
+ if (n <= NPAR_GEOP) then
+ do k=2,n
+ geop_d(k)=geop_d(k-1)*factor
+ end do
+ else
+ do k=2,NPAR2_GEOP
+ geop_d(k)=geop_d(k-1)*factor
+ end do
+ temp=factor**NPAR2_GEOP
+ k=NPAR2_GEOP
+ do
+ if (k >= n) exit
+ k2=k+k
+ geop_d(k+1:min(k2,n))=temp*geop_d(1:min(k,n-k))
+ temp=temp*temp
+ k=k2
+ end do
+ end if
+ END FUNCTION geop_d
+!BL
+ FUNCTION geop_i(first,factor,n)
+ INTEGER(I4B), INTENT(IN) :: first,factor,n
+ INTEGER(I4B), DIMENSION(n) :: geop_i
+ INTEGER(I4B) :: k,k2,temp
+ if (n > 0) geop_i(1)=first
+ if (n <= NPAR_GEOP) then
+ do k=2,n
+ geop_i(k)=geop_i(k-1)*factor
+ end do
+ else
+ do k=2,NPAR2_GEOP
+ geop_i(k)=geop_i(k-1)*factor
+ end do
+ temp=factor**NPAR2_GEOP
+ k=NPAR2_GEOP
+ do
+ if (k >= n) exit
+ k2=k+k
+ geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k))
+ temp=temp*temp
+ k=k2
+ end do
+ end if
+ END FUNCTION geop_i
+!BL
+ FUNCTION geop_c(first,factor,n)
+ COMPLEX(SP), INTENT(IN) :: first,factor
+ INTEGER(I4B), INTENT(IN) :: n
+ COMPLEX(SP), DIMENSION(n) :: geop_c
+ INTEGER(I4B) :: k,k2
+ COMPLEX(SP) :: temp
+ if (n > 0) geop_c(1)=first
+ if (n <= NPAR_GEOP) then
+ do k=2,n
+ geop_c(k)=geop_c(k-1)*factor
+ end do
+ else
+ do k=2,NPAR2_GEOP
+ geop_c(k)=geop_c(k-1)*factor
+ end do
+ temp=factor**NPAR2_GEOP
+ k=NPAR2_GEOP
+ do
+ if (k >= n) exit
+ k2=k+k
+ geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k))
+ temp=temp*temp
+ k=k2
+ end do
+ end if
+ END FUNCTION geop_c
+!BL
+ FUNCTION geop_dv(first,factor,n)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DP), DIMENSION(size(first),n) :: geop_dv
+ INTEGER(I4B) :: k,k2
+ REAL(DP), DIMENSION(size(first)) :: temp
+ if (n > 0) geop_dv(:,1)=first(:)
+ if (n <= NPAR_GEOP) then
+ do k=2,n
+ geop_dv(:,k)=geop_dv(:,k-1)*factor(:)
+ end do
+ else
+ do k=2,NPAR2_GEOP
+ geop_dv(:,k)=geop_dv(:,k-1)*factor(:)
+ end do
+ temp=factor**NPAR2_GEOP
+ k=NPAR2_GEOP
+ do
+ if (k >= n) exit
+ k2=k+k
+ geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*&
+ spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2))
+ temp=temp*temp
+ k=k2
+ end do
+ end if
+ END FUNCTION geop_dv
+!BL
+!BL
+ RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ REAL(SP), OPTIONAL, INTENT(IN) :: seed
+ REAL(SP), DIMENSION(size(arr)) :: ans
+ INTEGER(I4B) :: n,j
+ REAL(SP) :: sd
+ n=size(arr)
+ if (n == 0_i4b) RETURN
+ sd=0.0_sp
+ if (present(seed)) sd=seed
+ ans(1)=arr(1)+sd
+ if (n < NPAR_CUMSUM) then
+ do j=2,n
+ ans(j)=ans(j-1)+arr(j)
+ end do
+ else
+ ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd)
+ ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2)
+ end if
+ END FUNCTION cumsum_r
+!BL
+ RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans)
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed
+ INTEGER(I4B), DIMENSION(size(arr)) :: ans
+ INTEGER(I4B) :: n,j,sd
+ n=size(arr)
+ if (n == 0_i4b) RETURN
+ sd=0_i4b
+ if (present(seed)) sd=seed
+ ans(1)=arr(1)+sd
+ if (n < NPAR_CUMSUM) then
+ do j=2,n
+ ans(j)=ans(j-1)+arr(j)
+ end do
+ else
+ ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd)
+ ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2)
+ end if
+ END FUNCTION cumsum_i
+!BL
+!BL
+ RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: arr
+ REAL(SP), OPTIONAL, INTENT(IN) :: seed
+ REAL(SP), DIMENSION(size(arr)) :: ans
+ INTEGER(I4B) :: n,j
+ REAL(SP) :: sd
+ n=size(arr)
+ if (n == 0_i4b) RETURN
+ sd=1.0_sp
+ if (present(seed)) sd=seed
+ ans(1)=arr(1)*sd
+ if (n < NPAR_CUMPROD) then
+ do j=2,n
+ ans(j)=ans(j-1)*arr(j)
+ end do
+ else
+ ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd)
+ ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2)
+ end if
+ END FUNCTION cumprod
+!BL
+!BL
+ FUNCTION poly_rr(x,coeffs)
+ REAL(SP), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs
+ REAL(SP) :: poly_rr
+ REAL(SP) :: pow
+ REAL(SP), DIMENSION(:), ALLOCATABLE :: vec
+ INTEGER(I4B) :: i,n,nn
+ n=size(coeffs)
+ if (n <= 0) then
+ poly_rr=0.0_sp
+ else if (n < NPAR_POLY) then
+ poly_rr=coeffs(n)
+ do i=n-1,1,-1
+ poly_rr=x*poly_rr+coeffs(i)
+ end do
+ else
+ allocate(vec(n+1))
+ pow=x
+ vec(1:n)=coeffs
+ do
+ vec(n+1)=0.0_sp
+ nn=ishft(n+1,-1)
+ vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
+ if (nn == 1) exit
+ pow=pow*pow
+ n=nn
+ end do
+ poly_rr=vec(1)
+ deallocate(vec)
+ end if
+ END FUNCTION poly_rr
+!BL
+ FUNCTION poly_dd(x,coeffs)
+ REAL(DP), INTENT(IN) :: x
+ REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs
+ REAL(DP) :: poly_dd
+ REAL(DP) :: pow
+ REAL(DP), DIMENSION(:), ALLOCATABLE :: vec
+ INTEGER(I4B) :: i,n,nn
+ n=size(coeffs)
+ if (n <= 0) then
+ poly_dd=0.0_dp
+ else if (n < NPAR_POLY) then
+ poly_dd=coeffs(n)
+ do i=n-1,1,-1
+ poly_dd=x*poly_dd+coeffs(i)
+ end do
+ else
+ allocate(vec(n+1))
+ pow=x
+ vec(1:n)=coeffs
+ do
+ vec(n+1)=0.0_dp
+ nn=ishft(n+1,-1)
+ vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
+ if (nn == 1) exit
+ pow=pow*pow
+ n=nn
+ end do
+ poly_dd=vec(1)
+ deallocate(vec)
+ end if
+ END FUNCTION poly_dd
+!BL
+ FUNCTION poly_rc(x,coeffs)
+ COMPLEX(SPC), INTENT(IN) :: x
+ REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs
+ COMPLEX(SPC) :: poly_rc
+ COMPLEX(SPC) :: pow
+ COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec
+ INTEGER(I4B) :: i,n,nn
+ n=size(coeffs)
+ if (n <= 0) then
+ poly_rc=0.0_sp
+ else if (n < NPAR_POLY) then
+ poly_rc=coeffs(n)
+ do i=n-1,1,-1
+ poly_rc=x*poly_rc+coeffs(i)
+ end do
+ else
+ allocate(vec(n+1))
+ pow=x
+ vec(1:n)=coeffs
+ do
+ vec(n+1)=0.0_sp
+ nn=ishft(n+1,-1)
+ vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
+ if (nn == 1) exit
+ pow=pow*pow
+ n=nn
+ end do
+ poly_rc=vec(1)
+ deallocate(vec)
+ end if
+ END FUNCTION poly_rc
+!BL
+ FUNCTION poly_cc(x,coeffs)
+ COMPLEX(SPC), INTENT(IN) :: x
+ COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs
+ COMPLEX(SPC) :: poly_cc
+ COMPLEX(SPC) :: pow
+ COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec
+ INTEGER(I4B) :: i,n,nn
+ n=size(coeffs)
+ if (n <= 0) then
+ poly_cc=0.0_sp
+ else if (n < NPAR_POLY) then
+ poly_cc=coeffs(n)
+ do i=n-1,1,-1
+ poly_cc=x*poly_cc+coeffs(i)
+ end do
+ else
+ allocate(vec(n+1))
+ pow=x
+ vec(1:n)=coeffs
+ do
+ vec(n+1)=0.0_sp
+ nn=ishft(n+1,-1)
+ vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2)
+ if (nn == 1) exit
+ pow=pow*pow
+ n=nn
+ end do
+ poly_cc=vec(1)
+ deallocate(vec)
+ end if
+ END FUNCTION poly_cc
+!BL
+ FUNCTION poly_rrv(x,coeffs)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x
+ REAL(SP), DIMENSION(size(x)) :: poly_rrv
+ INTEGER(I4B) :: i,n,m
+ m=size(coeffs)
+ n=size(x)
+ if (m <= 0) then
+ poly_rrv=0.0_sp
+ else if (m < n .or. m < NPAR_POLY) then
+ poly_rrv=coeffs(m)
+ do i=m-1,1,-1
+ poly_rrv=x*poly_rrv+coeffs(i)
+ end do
+ else
+ do i=1,n
+ poly_rrv(i)=poly_rr(x(i),coeffs)
+ end do
+ end if
+ END FUNCTION poly_rrv
+!BL
+ FUNCTION poly_ddv(x,coeffs)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x
+ REAL(DP), DIMENSION(size(x)) :: poly_ddv
+ INTEGER(I4B) :: i,n,m
+ m=size(coeffs)
+ n=size(x)
+ if (m <= 0) then
+ poly_ddv=0.0_dp
+ else if (m < n .or. m < NPAR_POLY) then
+ poly_ddv=coeffs(m)
+ do i=m-1,1,-1
+ poly_ddv=x*poly_ddv+coeffs(i)
+ end do
+ else
+ do i=1,n
+ poly_ddv(i)=poly_dd(x(i),coeffs)
+ end do
+ end if
+ END FUNCTION poly_ddv
+!BL
+ FUNCTION poly_msk_rrv(x,coeffs,mask)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
+ REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv
+ poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp)
+ END FUNCTION poly_msk_rrv
+!BL
+ FUNCTION poly_msk_ddv(x,coeffs,mask)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: coeffs,x
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask
+ REAL(DP), DIMENSION(size(x)) :: poly_msk_ddv
+ poly_msk_ddv=unpack(poly_ddv(pack(x,mask),coeffs),mask,0.0_dp)
+ END FUNCTION poly_msk_ddv
+!BL
+!BL
+ RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a
+ REAL(SP), INTENT(IN) :: b
+ REAL(SP), DIMENSION(size(a)) :: u
+ INTEGER(I4B) :: n,j
+ n=size(a)
+ if (n <= 0) RETURN
+ u(1)=a(1)
+ if (n < NPAR_POLYTERM) then
+ do j=2,n
+ u(j)=a(j)+b*u(j-1)
+ end do
+ else
+ u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b)
+ u(3:n:2)=a(3:n:2)+b*u(2:n-1:2)
+ end if
+ END FUNCTION poly_term_rr
+!BL
+ RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u)
+ COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a
+ COMPLEX(SPC), INTENT(IN) :: b
+ COMPLEX(SPC), DIMENSION(size(a)) :: u
+ INTEGER(I4B) :: n,j
+ n=size(a)
+ if (n <= 0) RETURN
+ u(1)=a(1)
+ if (n < NPAR_POLYTERM) then
+ do j=2,n
+ u(j)=a(j)+b*u(j-1)
+ end do
+ else
+ u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b)
+ u(3:n:2)=a(3:n:2)+b*u(2:n-1:2)
+ end if
+ END FUNCTION poly_term_cc
+!BL
+!BL
+ FUNCTION zroots_unity(n,nn)
+ INTEGER(I4B), INTENT(IN) :: n,nn
+ COMPLEX(SPC), DIMENSION(nn) :: zroots_unity
+ INTEGER(I4B) :: k
+ REAL(SP) :: theta
+ zroots_unity(1)=1.0
+ theta=TWOPI/n
+ k=1
+ do
+ if (k >= nn) exit
+ zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC)
+ zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*&
+ zroots_unity(2:min(k,nn-k))
+ k=2*k
+ end do
+ END FUNCTION zroots_unity
+!BL
+ FUNCTION outerprod_r(a,b)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r
+ outerprod_r = spread(a,dim=2,ncopies=size(b)) * &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerprod_r
+!BL
+ FUNCTION outerprod_d(a,b)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(DP), DIMENSION(size(a),size(b)) :: outerprod_d
+ outerprod_d = spread(a,dim=2,ncopies=size(b)) * &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerprod_d
+!BL
+ FUNCTION outerdiv(a,b)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv
+ outerdiv = spread(a,dim=2,ncopies=size(b)) / &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerdiv
+!BL
+ FUNCTION outersum(a,b)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(size(a),size(b)) :: outersum
+ outersum = spread(a,dim=2,ncopies=size(b)) + &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outersum
+!BL
+ FUNCTION outerdiff_r(a,b)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r
+ outerdiff_r = spread(a,dim=2,ncopies=size(b)) - &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerdiff_r
+!BL
+ FUNCTION outerdiff_d(a,b)
+ REAL(DP), DIMENSION(:), INTENT(IN) :: a,b
+ REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d
+ outerdiff_d = spread(a,dim=2,ncopies=size(b)) - &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerdiff_d
+!BL
+ FUNCTION outerdiff_i(a,b)
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b
+ INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i
+ outerdiff_i = spread(a,dim=2,ncopies=size(b)) - &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerdiff_i
+!BL
+ FUNCTION outerand(a,b)
+ LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b
+ LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand
+ outerand = spread(a,dim=2,ncopies=size(b)) .and. &
+ spread(b,dim=1,ncopies=size(a))
+ END FUNCTION outerand
+!BL
+ SUBROUTINE scatter_add_r(dest,source,dest_index)
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
+ REAL(SP), DIMENSION(:), INTENT(IN) :: source
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
+ INTEGER(I4B) :: m,n,j,i
+ n=assert_eq2(size(source),size(dest_index),'scatter_add_r')
+ m=size(dest)
+ do j=1,n
+ i=dest_index(j)
+ if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j)
+ end do
+ END SUBROUTINE scatter_add_r
+ SUBROUTINE scatter_add_d(dest,source,dest_index)
+ REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
+ REAL(DP), DIMENSION(:), INTENT(IN) :: source
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
+ INTEGER(I4B) :: m,n,j,i
+ n=assert_eq2(size(source),size(dest_index),'scatter_add_d')
+ m=size(dest)
+ do j=1,n
+ i=dest_index(j)
+ if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j)
+ end do
+ END SUBROUTINE scatter_add_d
+ SUBROUTINE scatter_max_r(dest,source,dest_index)
+ REAL(SP), DIMENSION(:), INTENT(OUT) :: dest
+ REAL(SP), DIMENSION(:), INTENT(IN) :: source
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
+ INTEGER(I4B) :: m,n,j,i
+ n=assert_eq2(size(source),size(dest_index),'scatter_max_r')
+ m=size(dest)
+ do j=1,n
+ i=dest_index(j)
+ if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j))
+ end do
+ END SUBROUTINE scatter_max_r
+ SUBROUTINE scatter_max_d(dest,source,dest_index)
+ REAL(DP), DIMENSION(:), INTENT(OUT) :: dest
+ REAL(DP), DIMENSION(:), INTENT(IN) :: source
+ INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index
+ INTEGER(I4B) :: m,n,j,i
+ n=assert_eq2(size(source),size(dest_index),'scatter_max_d')
+ m=size(dest)
+ do j=1,n
+ i=dest_index(j)
+ if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j))
+ end do
+ END SUBROUTINE scatter_max_d
+!BL
+ SUBROUTINE diagadd_rv(mat,diag)
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ REAL(SP), DIMENSION(:), INTENT(IN) :: diag
+ INTEGER(I4B) :: j,n
+ n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv')
+ do j=1,n
+ mat(j,j)=mat(j,j)+diag(j)
+ end do
+ END SUBROUTINE diagadd_rv
+!BL
+ SUBROUTINE diagadd_r(mat,diag)
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ REAL(SP), INTENT(IN) :: diag
+ INTEGER(I4B) :: j,n
+ n = min(size(mat,1),size(mat,2))
+ do j=1,n
+ mat(j,j)=mat(j,j)+diag
+ end do
+ END SUBROUTINE diagadd_r
+!BL
+ SUBROUTINE diagmult_rv(mat,diag)
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ REAL(SP), DIMENSION(:), INTENT(IN) :: diag
+ INTEGER(I4B) :: j,n
+ n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv')
+ do j=1,n
+ mat(j,j)=mat(j,j)*diag(j)
+ end do
+ END SUBROUTINE diagmult_rv
+!BL
+ SUBROUTINE diagmult_r(mat,diag)
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ REAL(SP), INTENT(IN) :: diag
+ INTEGER(I4B) :: j,n
+ n = min(size(mat,1),size(mat,2))
+ do j=1,n
+ mat(j,j)=mat(j,j)*diag
+ end do
+ END SUBROUTINE diagmult_r
+!BL
+ FUNCTION get_diag_rv(mat)
+ REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat
+ REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv
+ INTEGER(I4B) :: j
+ j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv')
+ do j=1,size(mat,1)
+ get_diag_rv(j)=mat(j,j)
+ end do
+ END FUNCTION get_diag_rv
+!BL
+ FUNCTION get_diag_dv(mat)
+ REAL(DP), DIMENSION(:,:), INTENT(IN) :: mat
+ REAL(DP), DIMENSION(size(mat,1)) :: get_diag_dv
+ INTEGER(I4B) :: j
+ j=assert_eq2(size(mat,1),size(mat,2),'get_diag_dv')
+ do j=1,size(mat,1)
+ get_diag_dv(j)=mat(j,j)
+ end do
+ END FUNCTION get_diag_dv
+!BL
+ SUBROUTINE put_diag_rv(diagv,mat)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: diagv
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ INTEGER(I4B) :: j,n
+ n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv')
+ do j=1,n
+ mat(j,j)=diagv(j)
+ end do
+ END SUBROUTINE put_diag_rv
+!BL
+ SUBROUTINE put_diag_r(scal,mat)
+ REAL(SP), INTENT(IN) :: scal
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat
+ INTEGER(I4B) :: j,n
+ n = min(size(mat,1),size(mat,2))
+ do j=1,n
+ mat(j,j)=scal
+ end do
+ END SUBROUTINE put_diag_r
+!BL
+ SUBROUTINE unit_matrix(mat)
+ REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat
+ INTEGER(I4B) :: i,n
+ n=min(size(mat,1),size(mat,2))
+ mat(:,:)=0.0_sp
+ do i=1,n
+ mat(i,i)=1.0_sp
+ end do
+ END SUBROUTINE unit_matrix
+!BL
+ FUNCTION upper_triangle(j,k,extra)
+ INTEGER(I4B), INTENT(IN) :: j,k
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra
+ LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle
+ INTEGER(I4B) :: n
+ n=0
+ if (present(extra)) n=extra
+ upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n)
+ END FUNCTION upper_triangle
+!BL
+ FUNCTION lower_triangle(j,k,extra)
+ INTEGER(I4B), INTENT(IN) :: j,k
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra
+ LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle
+ INTEGER(I4B) :: n
+ n=0
+ if (present(extra)) n=extra
+ lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n)
+ END FUNCTION lower_triangle
+!BL
+ FUNCTION vabs(v)
+ REAL(SP), DIMENSION(:), INTENT(IN) :: v
+ REAL(SP) :: vabs
+ vabs=sqrt(dot_product(v,v))
+ END FUNCTION vabs
+!BL
+END MODULE nrutil
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/old_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/old_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b20de8938b369260f881299181d08c1a52d2e022
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/old_mod.f90
@@ -0,0 +1,860 @@
+module old_mod
+ use donnees_mod
+ use tab_mod
+ use remaillage_mod
+ use interpolation_mod
+contains
+
+
+
+ subroutine crea_part_old
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,m
+
+ m=cutoff*maxval(sqrt(omgx**2+omgy**2+omgz**2))
+ npart=0
+ numpg=0
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ if (sqrt(omgx(i,j,k)**2+omgy(i,j,k)**2+omgz(i,j,k)**2)>=m) then
+ npart=npart+1
+ numpg(i,j,k)=npart
+ xp(npart)=x
+ yp(npart)=y
+ zp(npart)=z
+ vx(npart)=vxg(i,j,k)
+ vy(npart)=vyg(i,j,k)
+ vz(npart)=vzg(i,j,k)
+ omx(npart)=omgx(i,j,k)
+ omy(npart)=omgy(i,j,k)
+ omz(npart)=omgz(i,j,k)
+ stx(npart)=stxg(i,j,k)
+ sty(npart)=styg(i,j,k)
+ stz(npart)=stzg(i,j,k)
+ end if
+ end do
+ end do
+ end do
+
+ end subroutine crea_part_old
+
+
+
+
+ subroutine advection_old()
+ implicit none
+
+ real(kind=8),dimension(:),pointer :: xp0,yp0,zp0,omx0,omy0,omz0
+ integer :: i,ib
+
+ allocate (xp0(1:npart),yp0(1:npart),zp0(1:npart))
+
+ !mise en memoire de la position initiale
+ !----------------------------------------
+ do i=1,npart
+ xp0(i)=xp(i)
+ yp0(i)=yp(i)
+ zp0(i)=zp(i)
+
+ !advection de la moitie d'un pas de temps : sous ite RK
+ !------------------------------------------------------
+
+ xp(i)=xp0(i)+0.5*dt*vx(i)
+ yp(i)=yp0(i)+0.5*dt*vy(i)
+ zp(i)=zp0(i)+0.5*dt*vz(i)
+
+ end do
+
+
+ call interpo_l3_3d(vxg,xp,yp,zp,vx)
+ call interpo_l3_3d(vyg,xp,yp,zp,vy)
+ call interpo_l3_3d(vzg,xp,yp,zp,vz)
+
+ call interpo_l3_3d(stxg,xp,yp,zp,stx)
+ call interpo_l3_3d(styg,xp,yp,zp,sty)
+ call interpo_l3_3d(stzg,xp,yp,zp,stz)
+
+
+ !advection depuis position initiale avec cette nouvelle vitesse : seconde ite de RK
+ !----------------------------------------------------------------------------------
+ do i=1,npart
+ xp(i)=xp0(i)+dt*vx(i)
+ yp(i)=yp0(i)+dt*vy(i)
+ zp(i)=zp0(i)+dt*vz(i)
+
+ omx(i)=omx(i)+dt*stx(i)
+ omy(i)=omy(i)+dt*sty(i)
+ omz(i)=omz(i)+dt*stz(i)
+ end do
+
+
+ deallocate(xp0,yp0,zp0)
+
+ end subroutine advection_old
+
+
+ subroutine penal_exacte
+ implicit none
+ real(kind=8) :: dyvecez,dzvecey,dzvecex,dxvecez,dxvecey,dyvecex
+ integer :: i,j,k
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ real(kind=8) :: facx,facy,facz
+
+
+ !PENALISATION
+ !--------------
+ ! si (on est dans l'obstacle ou derive(chi)/=0)) alors
+ ! omega = rot (vitesse*exp(-lambda*chi*dt) )
+
+
+
+
+
+ do k=1,nz ! ordre 4
+ do j=1,ny
+ do i=1,nx
+
+ !calcul penalisation uniquement dans l'obstacle et environs
+ if (.not.((chi(i,j,k)==0.).and.(derivx(chi,i,j,k)==0.) &
+ .and.(derivy(chi,i,j,k)==0.).and.(derivz(chi,i,j,k)==0.))) then
+
+
+
+ if((i/=2).and.(i/=1).and.(i/=nx-1).and.(i/=nx).and.(j/=2) &
+ .and.(j/=1).and.(j/=ny-1).and.(j/=ny).and.(k/=2).and.(k/=1) &
+ .and.(k/=nz-1).and.(k/=nz))then
+ !schema centre au milieu du domaine
+
+ omgx(i,j,k)=1./(12.*dy)*(1.*penz(i,j-2,k)-8.*penz(i,j-1,k) &
+ +8.*penz(i,j+1,k)-1.*penz(i,j+2,k))-(1./(12.*dz)*(1.*peny(i,j,k-2)-8.*peny(i,j,k-1) &
+ +8.*peny(i,j,k+1)-1.*peny(i,j,k+2)))
+ omgy(i,j,k)=1./(12.*dz)*(1.*penx(i,j,k-2)-8.*penx(i,j,k-1) &
+ +8.*penx(i,j,k+1)-1.*penx(i,j,k+2))-(1./(12.*dx)*(1.*penz(i-2,j,k)-8.*penz(i-1,j,k) &
+ +8.*penz(i+1,j,k)-1.*penz(i+2,j,k)))
+ omgz(i,j,k)=1./(12.*dx)*(1.*peny(i-2,j,k)-8.*peny(i-1,j,k) &
+ +8.*peny(i+1,j,k)-1.*peny(i+2,j,k))-(1./(12.*dy)*(1.*penx(i,j-2,k)-8.*penx(i,j-1,k) &
+ +8.*penx(i,j+1,k)-1.*penx(i,j+2,k)))
+
+ else
+
+ dxvecey=1./(12.*dx)*(1.*peny(i-2,j,k)-8.*peny(i-1,j,k)+8.*peny(i+1,j,k)-1.*peny(i+2,j,k))
+ dxvecez=1./(12.*dx)*(1.*penz(i-2,j,k)-8.*penz(i-1,j,k)+8.*penz(i+1,j,k)-1.*penz(i+2,j,k))
+ dyvecex=1./(12.*dy)*(1.*penx(i,j-2,k)-8.*penx(i,j-1,k)+8.*penx(i,j+1,k)-1.*penx(i,j+2,k))
+ dyvecez=1./(12.*dy)*(1.*penz(i,j-2,k)-8.*penz(i,j-1,k)+8.*penz(i,j+1,k)-1.*penz(i,j+2,k))
+ dzvecex=1./(12.*dz)*(1.*penx(i,j,k-2)-8.*penx(i,j,k-1)+8.*penx(i,j,k+1)-1.*penx(i,j,k+2))
+ dzvecey=1./(12.*dz)*(1.*peny(i,j,k-2)-8.*peny(i,j,k-1)+8.*peny(i,j,k+1)-1.*peny(i,j,k+2))
+
+
+
+ if((i==1).or.(i==2))then
+ dxvecey=1./(12.*dx)*(-25.*peny(i,j,k)+48.*peny(i+1,j,k)-36.*peny(i+2,j,k) &
+ +16.*peny(i+3,j,k)-3.*peny(i+4,j,k))
+ dxvecez=1./(12.*dx)*(-25.*penz(i,j,k)+48.*penz(i+1,j,k)-36.*penz(i+2,j,k) &
+ +16.*penz(i+3,j,k)-3.*penz(i+4,j,k))
+ end if
+
+ if((i==nx).or.(i==nx-1))then
+ dxvecey=1./(12.*dx)*(25.*peny(i,j,k)-48.*peny(i-1,j,k)+36.*peny(i-2,j,k) &
+ -16.*peny(i-3,j,k)+3.*peny(i-4,j,k))
+ dxvecez=1./(12.*dx)*(25.*penz(i,j,k)-48.*penz(i-1,j,k)+36.*penz(i-2,j,k) &
+ -16.*penz(i-3,j,k)+3.*penz(i-4,j,k))
+ endif
+
+ if((j==1).or.(j==2))then
+ dyvecez=1./(12.*dy)*(-25.*penz(i,j,k)+48.*penz(i,j+1,k)-36.*penz(i,j+2,k) &
+ +16.*penz(i,j+3,k)-3.*penz(i,j+4,k))
+ dyvecex=1./(12.*dy)*(-25.*penx(i,j,k)+48.*penx(i,j+1,k)-36.*penx(i,j+2,k) &
+ +16.*penx(i,j+3,k)-3.*penx(i,j+4,k))
+ end if
+
+ if((j==ny).or.(j==ny-1))then
+ dyvecez=1./(12.*dy)*(+25.*penz(i,j,k)-48.*penz(i,j-1,k)+36.*penz(i,j-2,k) &
+ -16.*penz(i,j-3,k)+3.*penz(i,j-4,k))
+ dyvecex=1./(12.*dy)*(+25.*penx(i,j,k)-48.*penx(i,j-1,k)+36.*penx(i,j-2,k) &
+ -16.*penx(i,j-3,k)+3.*penx(i,j-4,k))
+ endif
+
+ if((k==1).or.(k==2))then
+ dzvecex=1./(12.*dz)*(-25.*penx(i,j,k)+48.*penx(i,j,k+1)-36.*penx(i,j,k+2) &
+ +16.*penx(i,j,k+3)-3.*penx(i,j,k+4))
+ dzvecey=1./(12.*dz)*(-25.*peny(i,j,k)+48.*peny(i,j,k+1)-36.*peny(i,j,k+2) &
+ +16.*peny(i,j,k+3)-3.*peny(i,j,k+4))
+ end if
+
+ if((k==nz).or.(k==nz-1))then
+ dzvecex=1./(12.*dz)*(25.*penx(i,j,k)-48.*penx(i,j,k-1)+36.*penx(i,j,k-2) &
+ -16.*penx(i,j,k-3)+3.*penx(i,j,k-4))
+ dzvecey=1./(12.*dz)*(25.*peny(i,j,k)-48.*peny(i,j,k-1)+36.*peny(i,j,k-2) &
+ -16.*peny(i,j,k-3)+3.*peny(i,j,k-4))
+ endif
+
+
+
+ omgx(i,j,k)=dyvecez-dzvecey
+ omgy(i,j,k)=dzvecex-dxvecez
+ omgz(i,j,k)=dxvecey-dyvecex
+
+ end if
+
+ end if
+ end do
+ end do
+ end do
+
+ contains
+
+ function penx (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penx
+
+
+ !penx=vxg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ penx=vxg(l,m,n)/(1.+lambda(l,m,n)*chi(l,m,n)*dt)
+
+ end function penx
+
+ function peny (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: peny
+
+
+ !peny=vyg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ peny=vyg(l,m,n)/(1.+lambda(l,m,n)*chi(l,m,n)*dt)
+
+ end function peny
+
+ function penz (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penz
+
+
+ !penz=vzg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ penz=vzg(l,m,n)/(1.+lambda(l,m,n)*chi(l,m,n)*dt)
+
+ end function penz
+
+ end subroutine penal_exacte
+
+
+
+
+ function derivx (var,i,j,k) result (vars) ! calcul derive en x de var (decentre au bord, centre milieu) !ordre4
+ implicit none
+ real(kind=8),dimension(:,:,:) :: var
+ integer :: i,j,k
+ real(kind=8) :: vars
+
+ if((i/=2).and.(i/=1).and.(i/=nx-1).and.(i/=nx))then
+ !schema centre au milieu du domaine
+ vars=1./(12.*dx)*(1.*var(i-2,j,k)-8.*var(i-1,j,k)+8.*var(i+1,j,k)-1.*var(i+2,j,k))
+ else
+ if((i==1).or.(i==2))then
+ vars=1./(12.*dx)*(-25.*var(i,j,k)+48.*var(i+1,j,k)-36.*var(i+2,j,k)+16.*var(i+3,j,k)-3.*var(i+4,j,k))
+ end if
+ if((i==nx).or.(i==nx-1))then
+ vars=1./(12.*dx)*(+25.*var(i,j,k)-48.*var(i-1,j,k)+36.*var(i-2,j,k)-16.*var(i-3,j,k)+3.*var(i-4,j,k))
+ endif
+ end if
+ end function derivx
+
+ function derivy (var,i,j,k) result(vars) ! calcul derive en y de var (decentre au bord, centre milieu) !ordre4
+ implicit none
+ real(kind=8),dimension(:,:,:) :: var
+ integer :: i,j,k
+ real(kind=8) :: vars
+
+ if((j/=2).and.(j/=1).and.(j/=ny-1).and.(j/=ny))then
+ !schema centre au milieu du domaine
+ vars=1./(12.*dy)*(1.*var(i,j-2,k)-8.*var(i,j-1,k)+8.*var(i,j+1,k)-1.*var(i,j+2,k))
+ else
+ if((j==1).or.(j==2))then
+ vars=1./(12.*dy)*(-25.*var(i,j,k)+48.*var(i,j+1,k)-36.*var(i,j+2,k)+16.*var(i,j+3,k)-3.*var(i,j+4,k))
+ end if
+ if((j==ny).or.(j==ny-1))then
+ vars=1./(12.*dy)*(+25.*var(i,j,k)-48.*var(i,j-1,k)+36.*var(i,j-2,k)-16.*var(i,j-3,k)+3.*var(i,j-4,k))
+ endif
+ end if
+ end function derivy
+
+ function derivz (var,i,j,k) result(vars) ! calcul derive en z de var (decentre au bord, centre milieu) !ordre4
+ implicit none
+ real(kind=8),dimension(:,:,:) :: var
+ integer :: i,j,k
+ real(kind=8) :: vars
+
+ if((k/=2).and.(k/=1).and.(k/=nz-1).and.(k/=nz))then
+ !schema centre au milieu du domaine
+ vars=1./(12.*dz)*(1.*var(i,j,k-2)-8.*var(i,j,k-1)+8.*var(i,j,k+1)-1.*var(i,j,k+2))
+ else
+ if((k==1).or.(k==2))then
+ vars=1./(12.*dz)*(-25.*var(i,j,k)+48.*var(i,j,k+1)-36.*var(i,j,k+2)+16.*var(i,j,k+3)-3.*var(i,j,k+4))
+ end if
+ if((k==ny).or.(k==ny-1))then
+ vars=1./(12.*dz)*(+25.*var(i,j,k)-48.*var(i,j,k-1)+36.*var(i,j,k-2)-16.*var(i,j,k-3)+3.*var(i,j,k-4))
+ endif
+ end if
+ end function derivz
+
+
+
+
+
+ subroutine strech_old()
+ implicit none
+ integer :: i,j,k
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ real(kind=8) :: x,y,z
+
+ !forme conservative : div(w:u)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+!!$ tx(1)=dx_c_4(vxg*omgx,i,j,k,dx)
+!!$ tx(2)=dx_c_4(vyg*omgx,i,j,k,dx)
+!!$ tx(3)=dx_c_4(vzg*omgx,i,j,k,dx)
+!!$
+!!$ ty(1)=dy_c_4(vxg*omgy,i,j,k,dy)
+!!$ ty(2)=dy_c_4(vyg*omgy,i,j,k,dy)
+!!$ ty(3)=dy_c_4(vzg*omgy,i,j,k,dy)
+!!$
+!!$ tz(1)=dz_c_4(vxg*omgz,i,j,k,dz)
+!!$ tz(2)=dz_c_4(vyg*omgz,i,j,k,dz)
+!!$ tz(3)=dz_c_4(vzg*omgz,i,j,k,dz)
+
+ tx(1)=1./(12.*dx)*(1.*omgx(i-2,j,k)*vxg(i-2,j,k)-8.*omgx(i-1,j,k)*vxg(i-1,j,k) &
+ +8.*omgx(i+1,j,k)*vxg(i+1,j,k)-1.*omgx(i+2,j,k)*vxg(i+2,j,k))
+ tx(2)=1./(12.*dx)*(1.*omgx(i-2,j,k)*vyg(i-2,j,k)-8.*omgx(i-1,j,k)*vyg(i-1,j,k) &
+ +8.*omgx(i+1,j,k)*vyg(i+1,j,k)-1.*omgx(i+2,j,k)*vyg(i+2,j,k))
+ tx(3)=1./(12.*dx)*(1.*omgx(i-2,j,k)*vzg(i-2,j,k)-8.*omgx(i-1,j,k)*vzg(i-1,j,k) &
+ +8.*omgx(i+1,j,k)*vzg(i+1,j,k)-1.*omgx(i+2,j,k)*vzg(i+2,j,k))
+
+ ty(1)=1./(12.*dy)*(1.*omgy(i,j-2,k)*vxg(i,j-2,k)-8.*omgy(i,j-1,k)*vxg(i,j-1,k) &
+ +8.*omgy(i,j+1,k)*vxg(i,j+1,k)-1.*omgy(i,j+2,k)*vxg(i,j+2,k))
+ ty(2)=1./(12.*dy)*(1.*omgy(i,j-2,k)*vyg(i,j-2,k)-8.*omgy(i,j-1,k)*vyg(i,j-1,k) &
+ +8.*omgy(i,j+1,k)*vyg(i,j+1,k)-1.*omgy(i,j+2,k)*vyg(i,j+2,k))
+ ty(3)=1./(12.*dy)*(1.*omgy(i,j-2,k)*vzg(i,j-2,k)-8.*omgy(i,j-1,k)*vzg(i,j-1,k) &
+ +8.*omgy(i,j+1,k)*vzg(i,j+1,k)-1.*omgy(i,j+2,k)*vzg(i,j+2,k))
+
+ tz(1)=1./(12.*dz)*(1.*omgz(i,j,k-2)*vxg(i,j,k-2)-8.*omgz(i,j,k-1)*vxg(i,j,k-1) &
+ +8.*omgz(i,j,k+1)*vxg(i,j,k+1)-1.*omgz(i,j,k+2)*vxg(i,j,k+2))
+ tz(2)=1./(12.*dz)*(1.*omgz(i,j,k-2)*vyg(i,j,k-2)-8.*omgz(i,j,k-1)*vyg(i,j,k-1) &
+ +8.*omgz(i,j,k+1)*vyg(i,j,k+1)-1.*omgz(i,j,k+2)*vyg(i,j,k+2))
+ tz(3)=1./(12.*dz)*(1.*omgz(i,j,k-2)*vzg(i,j,k-2)-8.*omgz(i,j,k-1)*vzg(i,j,k-1) &
+ +8.*omgz(i,j,k+1)*vzg(i,j,k+1)-1.*omgz(i,j,k+2)*vzg(i,j,k+2))
+
+!!$ !schema decentre au bord
+!!$ if((i==1).or.(i==2))then
+!!$ tx(1)=dx_dr_5(vxg*omgx,i,j,k,dx)
+!!$ tx(2)=dx_dr_5(vyg*omgx,i,j,k,dx)
+!!$ tx(3)=dx_dr_5(vzg*omgx,i,j,k,dx)
+!!$ end if
+!!$
+!!$ if((i==nx).or.(i==nx-1))then
+!!$ tx(1)=dx_ga_5(vxg*omgx,i,j,k,dx)
+!!$ tx(2)=dx_ga_5(vyg*omgx,i,j,k,dx)
+!!$ tx(3)=dx_ga_5(vzg*omgx,i,j,k,dx)
+!!$ endif
+!!$
+!!$ if((j==1).or.(j==2))then
+!!$ ty(1)=dy_dr_5(vxg*omgy,i,j,k,dy)
+!!$ ty(2)=dy_dr_5(vyg*omgy,i,j,k,dy)
+!!$ ty(3)=dy_dr_5(vzg*omgy,i,j,k,dy)
+!!$ end if
+!!$
+!!$ if((j==ny).or.(j==ny-1))then
+!!$ ty(1)=dy_ga_5(vxg*omgy,i,j,k,dy)
+!!$ ty(2)=dy_ga_5(vyg*omgy,i,j,k,dy)
+!!$ ty(3)=dy_ga_5(vzg*omgy,i,j,k,dy)
+!!$ endif
+!!$
+!!$ if((k==1).or.(k==2))then
+!!$ tz(1)=dz_ha_5(vxg*omgz,i,j,k,dz)
+!!$ tz(2)=dz_ha_5(vyg*omgz,i,j,k,dz)
+!!$ tz(3)=dz_ha_5(vzg*omgz,i,j,k,dz)
+!!$ end if
+!!$
+!!$ if((k==nz).or.(k==nz-1))then
+!!$ tz(1)=dz_ba_5(vxg*omgz,i,j,k,dz)
+!!$ tz(2)=dz_ba_5(vyg*omgz,i,j,k,dz)
+!!$ tz(3)=dz_ba_5(vzg*omgz,i,j,k,dz)
+!!$ endif
+
+ !schema decentre au bord
+ if((i==1).or.(i==2))then
+ tx(1)=1./(12.*dx)*(-25.*omgx(i,j,k)*vxg(i,j,k)+48.*omgx(i+1,j,k)*vxg(i+1,j,k) &
+ -36.*omgx(i+2,j,k)*vxg(i+2,j,k)+16.*omgx(i+3,j,k)*vxg(i+3,j,k)-3.*omgx(i+4,j,k)*vxg(i+4,j,k))
+ tx(2)=1./(12.*dx)*(-25.*omgx(i,j,k)*vyg(i,j,k)+48.*omgx(i+1,j,k)*vyg(i+1,j,k) &
+ -36.*omgx(i+2,j,k)*vyg(i+2,j,k)+16.*omgx(i+3,j,k)*vyg(i+3,j,k)-3.*omgx(i+4,j,k)*vyg(i+4,j,k))
+ tx(3)=1./(12.*dx)*(-25.*omgx(i,j,k)*vzg(i,j,k)+48.*omgx(i+1,j,k)*vzg(i+1,j,k) &
+ -36.*omgx(i+2,j,k)*vzg(i+2,j,k)+16.*omgx(i+3,j,k)*vzg(i+3,j,k)-3.*omgx(i+4,j,k)*vzg(i+4,j,k))
+ end if
+
+ if((i==nx).or.(i==nx-1))then
+ tx(1)=1./(12.*dx)*(-25.*omgx(i,j,k)*vxg(i,j,k)+48.*omgx(i-1,j,k)*vxg(i-1,j,k) &
+ -36.*omgx(i-2,j,k)*vxg(i-2,j,k)+16.*omgx(i-3,j,k)*vxg(i-3,j,k)-3.*omgx(i-4,j,k)*vxg(i-4,j,k))
+ tx(2)=1./(12.*dx)*(-25.*omgx(i,j,k)*vyg(i,j,k)+48.*omgx(i-1,j,k)*vyg(i-1,j,k) &
+ -36.*omgx(i-2,j,k)*vyg(i-2,j,k)+16.*omgx(i-3,j,k)*vyg(i-3,j,k)-3.*omgx(i-4,j,k)*vyg(i-4,j,k))
+ tx(3)=1./(12.*dx)*(-25.*omgx(i,j,k)*vzg(i,j,k)+48.*omgx(i-1,j,k)*vzg(i-1,j,k) &
+ -36.*omgx(i-2,j,k)*vzg(i-2,j,k)+16.*omgx(i-3,j,k)*vzg(i-3,j,k)-3.*omgx(i-4,j,k)*vzg(i-4,j,k))
+ endif
+
+ if((j==1).or.(j==2))then
+ ty(1)=1./(12.*dy)*(-25.*omgy(i,j,k)*vxg(i,j,k)+48.*omgy(i,j+1,k)*vxg(i,j+1,k) &
+ -36.*omgy(i,j+2,k)*vxg(i,j+2,k)+16.*omgy(i,j+3,k)*vxg(i,j+3,k)-3.*omgy(i,j+4,k)*vxg(i,j+4,k))
+ ty(2)=1./(12.*dy)*(-25.*omgy(i,j,k)*vyg(i,j,k)+48.*omgy(i,j+1,k)*vyg(i,j+1,k) &
+ -36.*omgy(i,j+2,k)*vyg(i,j+2,k)+16.*omgy(i,j+3,k)*vyg(i,j+3,k)-3.*omgy(i,j+4,k)*vyg(i,j+4,k))
+ ty(3)=1./(12.*dy)*(-25.*omgy(i,j,k)*vzg(i,j,k)+48.*omgy(i,j+1,k)*vzg(i,j+1,k) &
+ -36.*omgy(i,j+2,k)*vzg(i,j+2,k)+16.*omgy(i,j+3,k)*vzg(i,j+3,k)-3.*omgy(i,j+4,k)*vzg(i,j+4,k))
+ end if
+
+ if((j==ny).or.(j==ny-1))then
+ ty(1)=1./(12.*dy)*(-25.*omgy(i,j,k)*vxg(i,j,k)+48.*omgy(i,j-1,k)*vxg(i,j-1,k) &
+ -36.*omgy(i,j-2,k)*vxg(i,j-2,k)+16.*omgy(i,j-3,k)*vxg(i,j-3,k)-3.*omgy(i,j-4,k)*vxg(i,j-4,k))
+ ty(2)=1./(12.*dy)*(-25.*omgy(i,j,k)*vyg(i,j,k)+48.*omgy(i,j-1,k)*vyg(i,j-1,k) &
+ -36.*omgy(i,j-2,k)*vyg(i,j-2,k)+16.*omgy(i,j-3,k)*vyg(i,j-3,k)-3.*omgy(i,j-4,k)*vyg(i,j-4,k))
+ ty(3)=1./(12.*dy)*(-25.*omgy(i,j,k)*vzg(i,j,k)+48.*omgy(i,j-1,k)*vzg(i,j-1,k) &
+ -36.*omgy(i,j-2,k)*vzg(i,j-2,k)+16.*omgy(i,j-3,k)*vzg(i,j-3,k)-3.*omgy(i,j-4,k)*vzg(i,j-4,k))
+ endif
+
+ if((k==1).or.(k==2))then
+ tz(1)=1./(12.*dz)*(-25.*omgz(i,j,k)*vxg(i,j,k)+48.*omgz(i,j,k+1)*vxg(i,j,k+1) &
+ -36.*omgz(i,j,k+2)*vxg(i,j,k+2)+16.*omgz(i,j,k+3)*vxg(i,j,k+3)-3.*omgz(i,j,k+4)*vxg(i,j,k+4))
+ tz(2)=1./(12.*dz)*(-25.*omgz(i,j,k)*vyg(i,j,k)+48.*omgz(i,j,k+1)*vyg(i,j,k+1) &
+ -36.*omgz(i,j,k+2)*vyg(i,j,k+2)+16.*omgz(i,j,k+3)*vyg(i,j,k+3)-3.*omgz(i,j,k+4)*vyg(i,j,k+4))
+ tz(3)=1./(12.*dz)*(-25.*omgz(i,j,k)*vzg(i,j,k)+48.*omgz(i,j,k+1)*vzg(i,j,k+1) &
+ -36.*omgz(i,j,k+2)*vzg(i,j,k+2)+16.*omgz(i,j,k+3)*vzg(i,j,k+3)-3.*omgz(i,j,k+4)*vzg(i,j,k+4))
+ end if
+
+ if((k==nz).or.(k==nz-1))then
+ tz(1)=1./(12.*dz)*(-25.*omgz(i,j,k)*vxg(i,j,k)+48.*omgz(i,j,k-1)*vxg(i,j,k-1) &
+ -36.*omgz(i,j,k-2)*vxg(i,j,k-2)+16.*omgz(i,j,k-3)*vxg(i,j,k-3)-3.*omgz(i,j,k-4)*vxg(i,j,k-4))
+ tz(2)=1./(12.*dz)*(-25.*omgz(i,j,k)*vyg(i,j,k)+48.*omgz(i,j,k-1)*vyg(i,j,k-1) &
+ -36.*omgz(i,j,k-2)*vyg(i,j,k-2)+16.*omgz(i,j,k-3)*vyg(i,j,k-3)-3.*omgz(i,j,k-4)*vyg(i,j,k-4))
+ tz(3)=1./(12.*dz)*(-25.*omgz(i,j,k)*vzg(i,j,k)+48.*omgz(i,j,k-1)*vzg(i,j,k-1) &
+ -36.*omgz(i,j,k-2)*vzg(i,j,k-2)+16.*omgz(i,j,k-3)*vzg(i,j,k-3)-3.*omgz(i,j,k-4)*vzg(i,j,k-4))
+ endif
+
+ x=xg+(i-1)*dx
+ y=yb+(j-1)*dy
+ z=zd+(k-1)*dz
+
+
+
+ stxg(i,j,k)=tx(1)+ty(1)+tz(1)
+ styg(i,j,k)=tx(2)+ty(2)+tz(2)
+ stzg(i,j,k)=tx(3)+ty(3)+tz(3)
+ end do
+ end do
+ end do
+
+ end subroutine strech_old
+
+
+ subroutine diffusion_old
+ implicit none
+ real(kind=8),dimension(1:3,1:nx,1:ny,1:nz) :: diffusion
+ integer :: i,j,k
+ real(kind=8) :: facx,facy,facz
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+
+ facx=1.D0/(12.D0*dx**2)
+ facy=1.D0/(12.D0*dy**2)
+ facz=1.D0/(12.D0*dz**2)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ !ordre4
+ tx(1)=facx*(-omgx(ip2,j,k)+16.D0*omgx(ip1,j,k)-30.D0*omgx(i,j,k)+16.D0*omgx(im1,j,k)-omgx(im2,j,k))
+ tx(2)=facx*(-omgy(ip2,j,k)+16.D0*omgy(ip1,j,k)-30.D0*omgy(i,j,k)+16.D0*omgy(im1,j,k)-omgy(im2,j,k))
+ tx(3)=facx*(-omgz(ip2,j,k)+16.D0*omgz(ip1,j,k)-30.D0*omgz(i,j,k)+16.D0*omgz(im1,j,k)-omgz(im2,j,k))
+
+ ty(1)=facy*(-omgx(i,jp2,k)+16.D0*omgx(i,jp1,k)-30.D0*omgx(i,j,k)+16.D0*omgx(i,jm1,k)-omgx(i,jm2,k))
+ ty(2)=facy*(-omgy(i,jp2,k)+16.D0*omgy(i,jp1,k)-30.D0*omgy(i,j,k)+16.D0*omgy(i,jm1,k)-omgy(i,jm2,k))
+ ty(3)=facy*(-omgz(i,jp2,k)+16.D0*omgz(i,jp1,k)-30.D0*omgz(i,j,k)+16.D0*omgz(i,jm1,k)-omgz(i,jm2,k))
+
+ tz(1)=facz*(-omgx(i,j,kp2)+16.D0*omgx(i,j,kp1)-30.D0*omgx(i,j,k)+16.D0*omgx(i,j,km1)-omgx(i,j,km2))
+ tz(2)=facz*(-omgy(i,j,kp2)+16.D0*omgy(i,j,kp1)-30.D0*omgy(i,j,k)+16.D0*omgy(i,j,km1)-omgy(i,j,km2))
+ tz(3)=facz*(-omgz(i,j,kp2)+16.D0*omgz(i,j,kp1)-30.D0*omgz(i,j,k)+16.D0*omgz(i,j,km1)-omgz(i,j,km2))
+
+
+
+ diffusion(1,i,j,k)=tx(1)+ty(1)+tz(1)
+ diffusion(2,i,j,k)=tx(2)+ty(2)+tz(2)
+ diffusion(3,i,j,k)=tx(3)+ty(3)+tz(3)
+ end do
+ end do
+ end do
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ omgx(i,j,k)=omgx(i,j,k)+ nu*dt*diffusion(1,i,j,k)
+ omgy(i,j,k)=omgy(i,j,k)+ nu*dt*diffusion(2,i,j,k)
+ omgz(i,j,k)=omgz(i,j,k)+ nu*dt*diffusion(3,i,j,k)
+ end do
+ end do
+ end do
+
+ end subroutine diffusion_old
+
+
+ subroutine strech_diff_penal
+ implicit none
+ integer :: i,j,k
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ real(kind=8) :: x,y,z
+ real(kind=8) :: facx,facy,facz
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+
+
+
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+
+ facx=1.D0/(12.D0*dx)
+ facy=1.D0/(12.D0*dy)
+ facz=1.D0/(12.D0*dz)
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ !strech
+ !------
+ tx(1)=facx*(omgx(im2,j,k)*vxg(im2,j,k)-8.D0*omgx(im1,j,k)*vxg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vxg(ip1,j,k)-omgx(ip2,j,k)*vxg(ip2,j,k))
+ tx(2)=facx*(omgx(im2,j,k)*vyg(im2,j,k)-8.D0*omgx(im1,j,k)*vyg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vyg(ip1,j,k)-omgx(ip2,j,k)*vyg(ip2,j,k))
+ tx(3)=facx*(omgx(im2,j,k)*vzg(im2,j,k)-8.D0*omgx(im1,j,k)*vzg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vzg(ip1,j,k)-omgx(ip2,j,k)*vzg(ip2,j,k))
+
+ ty(1)=facy*(omgy(i,jm2,k)*vxg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vxg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vxg(i,jp1,k)-omgy(i,jp2,k)*vxg(i,jp2,k))
+ ty(2)=facy*(omgy(i,jm2,k)*vyg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vyg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vyg(i,jp1,k)-omgy(i,jp2,k)*vyg(i,jp2,k))
+ ty(3)=facy*(omgy(i,jm2,k)*vzg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vzg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vzg(i,jp1,k)-omgy(i,jp2,k)*vzg(i,jp2,k))
+
+ tz(1)=facz*(omgz(i,j,km2)*vxg(i,j,km2)-8.D0*omgz(i,j,km1)*vxg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vxg(i,j,kp1)-omgz(i,j,kp2)*vxg(i,j,kp2))
+ tz(2)=facz*(omgz(i,j,km2)*vyg(i,j,km2)-8.D0*omgz(i,j,km1)*vyg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vyg(i,j,kp1)-omgz(i,j,kp2)*vyg(i,j,kp2))
+ tz(3)=facz*(omgz(i,j,km2)*vzg(i,j,km2)-8.D0*omgz(i,j,km1)*vzg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vzg(i,j,kp1)-omgz(i,j,kp2)*vzg(i,j,kp2))
+
+
+
+ stxg(i,j,k)=tx(1)+ty(1)+tz(1)
+ styg(i,j,k)=tx(2)+ty(2)+tz(2)
+ stzg(i,j,k)=tx(3)+ty(3)+tz(3)
+
+
+ !diffusion
+ !----------
+ facx=1.D0/(12.D0*dx**2)
+ facy=1.D0/(12.D0*dy**2)
+ facz=1.D0/(12.D0*dz**2)
+
+ tx(1)=facx*(-omgx(ip2,j,k)+16.D0*omgx(ip1,j,k)-30.D0*omgx(i,j,k)+16.D0*omgx(im1,j,k)-omgx(im2,j,k))
+ tx(2)=facx*(-omgy(ip2,j,k)+16.D0*omgy(ip1,j,k)-30.D0*omgy(i,j,k)+16.D0*omgy(im1,j,k)-omgy(im2,j,k))
+ tx(3)=facx*(-omgz(ip2,j,k)+16.D0*omgz(ip1,j,k)-30.D0*omgz(i,j,k)+16.D0*omgz(im1,j,k)-omgz(im2,j,k))
+
+ ty(1)=facy*(-omgx(i,jp2,k)+16.D0*omgx(i,jp1,k)-30.D0*omgx(i,j,k)+16.D0*omgx(i,jm1,k)-omgx(i,jm2,k))
+ ty(2)=facy*(-omgy(i,jp2,k)+16.D0*omgy(i,jp1,k)-30.D0*omgy(i,j,k)+16.D0*omgy(i,jm1,k)-omgy(i,jm2,k))
+ ty(3)=facy*(-omgz(i,jp2,k)+16.D0*omgz(i,jp1,k)-30.D0*omgz(i,j,k)+16.D0*omgz(i,jm1,k)-omgz(i,jm2,k))
+
+ tz(1)=facz*(-omgx(i,j,kp2)+16.D0*omgx(i,j,kp1)-30.D0*omgx(i,j,k)+16.D0*omgx(i,j,km1)-omgx(i,j,km2))
+ tz(2)=facz*(-omgy(i,j,kp2)+16.D0*omgy(i,j,kp1)-30.D0*omgy(i,j,k)+16.D0*omgy(i,j,km1)-omgy(i,j,km2))
+ tz(3)=facz*(-omgz(i,j,kp2)+16.D0*omgz(i,j,kp1)-30.D0*omgz(i,j,k)+16.D0*omgz(i,j,km1)-omgz(i,j,km2))
+
+
+
+ stxg(i,j,k)=stxg(i,j,k)+nu*(tx(1)+ty(1)+tz(1))
+ styg(i,j,k)=styg(i,j,k)+nu*(tx(2)+ty(2)+tz(2))
+ stzg(i,j,k)=stzg(i,j,k)+nu*(tx(3)+ty(3)+tz(3))
+
+!!$ if (.not.((chi(i,j,k)==0.).and.(derivx(chi,i,j,k)==0.).and.(derivy(chi,i,j,k)==0.).and.(derivz(chi,i,j,k)==0.))) then
+ !penal
+ !-----
+!!$ facx=1.D0/(12.D0*dx)
+!!$ facy=1.D0/(12.D0*dy)
+!!$ facz=1.D0/(12.D0*dz)
+!!$
+!!$ tx(2)=facx*(peny(im2,j,k)-8.D0*peny(im1,j,k)+8.D0*peny(ip1,j,k)-peny(ip2,j,k))
+!!$ tx(3)=facx*(penz(im2,j,k)-8.D0*penz(im1,j,k)+8.D0*penz(ip1,j,k)-penz(ip2,j,k))
+!!$
+!!$ ty(1)=facy*(penx(i,jm2,k)-8.D0*penx(i,jm1,k)+8.D0*penx(i,jp1,k)-penx(i,jp2,k))
+!!$ ty(3)=facy*(penz(i,jm2,k)-8.D0*penz(i,jm1,k)+8.D0*penz(i,jp1,k)-penz(i,jp2,k))
+!!$
+!!$
+!!$ tz(1)=facz*(penx(i,j,km2)-8.D0*penx(i,j,km1)+8.D0*penx(i,j,kp1)-penx(i,j,kp2))
+!!$ tz(2)=facz*(peny(i,j,km2)-8.D0*peny(i,j,km1)+8.D0*peny(i,j,kp1)-peny(i,j,kp2))
+
+
+!!$
+!!$ !stxg(i,j,k)=stxg(i,j,k)+ty(3)-tz(2)
+!!$ !styg(i,j,k)=styg(i,j,k)+tz(1)-tx(3)
+!!$ !stzg(i,j,k)=stzg(i,j,k)+tx(2)-ty(1)
+!!$
+!!$ omgx(i,j,k)=ty(3)-tz(2)
+!!$ omgy(i,j,k)=tz(1)-tx(3)
+!!$ omgz(i,j,k)=tx(2)-ty(1)
+!!$
+!!$ !explicite
+!!$ !omgx(i,j,k)=omgx(i,j,k)+dt*(ty(3)-tz(2))
+!!$ !omgy(i,j,k)=omgy(i,j,k)+dt*(tz(1)-tx(3))
+!!$ !omgz(i,j,k)=omgz(i,j,k)+dt*(tx(2)-ty(1))
+
+!!$ tx=rot_vec_gradsca(vxg,vyg,vzg,exp(-lambda*chi*dt),i,j,k)
+!!$
+!!$ omgx(i,j,k)=omgx(i,j,k)*exp(-lambda*chi(i,j,k)*dt)-tx(1)
+!!$ omgy(i,j,k)=omgy(i,j,k)*exp(-lambda*chi(i,j,k)*dt)-tx(2)
+!!$ omgz(i,j,k)=omgz(i,j,k)*exp(-lambda*chi(i,j,k)*dt)-tx(3)
+
+!!$ tx=rot_vec_gradsca(vxg,vyg,vzg,1./(1.+lambda*dt*chi),i,j,k)
+!!$
+!!$ omgx(i,j,k)=omgx(i,j,k)/(1.+lambda*chi(i,j,k)*dt)-tx(1)
+!!$ omgy(i,j,k)=omgy(i,j,k)/(1.+lambda*chi(i,j,k)*dt)-tx(2)
+!!$ omgz(i,j,k)=omgz(i,j,k)/(1.+lambda*chi(i,j,k)*dt)-tx(3)
+
+!!$ tx=rot_vec_gradsca(vxg,vyg,vzg,1./(1.+lambda*dt*chi),i,j,k)
+!!$
+!!$ omgx(i,j,k)=omgx(i,j,k)*(1.-lambda*chi(i,j,k)*dt)-lambda*dt*tx(1)
+!!$ omgy(i,j,k)=omgy(i,j,k)*(1.-lambda*chi(i,j,k)*dt)-lambda*dt*tx(2)
+!!$ omgz(i,j,k)=omgz(i,j,k)*(1.-lambda*chi(i,j,k)*dt)-lambda*dt*tx(3)
+
+
+!!$ tx=rot_vec_gradsca(vxg,vyg,vzg,chi,i,j,k)
+!!$
+!!$ omgx(i,j,k)=omgx(i,j,k)+dt*lambda*tx(1)
+!!$ omgy(i,j,k)=omgy(i,j,k)+dt*lambda*tx(2)
+!!$ omgz(i,j,k)=omgz(i,j,k)+dt*lambda*tx(3)
+!!$
+!!$
+!!$ end if
+ end do
+ end do
+ end do
+
+ contains
+ function penx (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penx
+
+
+ penx=vxg(l,m,n)*exp(-lambda(l,m,n)*chi(l,m,n)*dt)
+ !penx=vxg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+ !penx=-lambda*chi(l,m,n)*vxg(l,m,n)
+ !penx=vxg(l,m,n)
+
+ end function penx
+
+ function peny (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: peny
+
+
+ peny=vyg(l,m,n)*exp(-lambda(l,m,n)*chi(l,m,n)*dt)
+ !peny=vyg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+ !peny=-lambda*chi(l,m,n)*vyg(l,m,n)
+ !peny=vyg(l,m,n)
+
+ end function peny
+
+ function penz (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penz
+
+
+ penz=vzg(l,m,n)*exp(-lambda(l,m,n)*chi(l,m,n)*dt)
+ !penz=vzg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+ !penz=-lambda*chi(l,m,n)*vzg(l,m,n)
+ !penz=vzg(l,m,n)
+
+ end function penz
+
+
+ function rot_vec_gradsca(vecx,vecy,vecz,sca,l,m,n) result(r)
+ implicit none
+ real(kind=8),dimension(:,:,:) :: vecx,vecy,vecz,sca
+ integer :: l,m,n
+ real(kind=8),dimension(1:3) :: r
+
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+ real(kind=8) :: facx,facy,facz,dxsca,dysca,dzsca
+
+ facx=1.D0/(12.D0*dx)
+ facy=1.D0/(12.D0*dy)
+ facz=1.D0/(12.D0*dz)
+
+ ip1=mod(l+1+nx-1,nx)+1
+ im1=mod(l-1+nx-1,nx)+1
+ ip2=mod(l+2+nx-1,nx)+1
+ im2=mod(l-2+nx-1,nx)+1
+
+ jp1=mod(m+1+ny-1,ny)+1
+ jm1=mod(m-1+ny-1,ny)+1
+ jp2=mod(m+2+ny-1,ny)+1
+ jm2=mod(m-2+ny-1,ny)+1
+
+ kp1=mod(n+1+nz-1,nz)+1
+ km1=mod(n-1+nz-1,nz)+1
+ kp2=mod(n+2+nz-1,nz)+1
+ km2=mod(n-2+nz-1,nz)+1
+
+ dxsca=facx*(sca(im2,j,k)-8.*sca(im1,j,k)+8.*sca(ip1,j,k)-sca(ip2,j,k))
+ dysca=facy*(sca(i,jm2,k)-8.*sca(i,jm1,k)+8.*sca(i,jp1,k)-sca(i,jp2,k))
+ dzsca=facz*(sca(i,j,km2)-8.*sca(i,j,km1)+8.*sca(i,j,kp1)-sca(i,j,kp2))
+
+ r(1)=vecy(l,m,n)*dzsca-vecz(l,m,n)*dysca
+ r(2)=vecz(l,m,n)*dxsca-vecx(l,m,n)*dzsca
+ r(3)=vecx(l,m,n)*dysca-vecy(l,m,n)*dxsca
+
+ end function rot_vec_gradsca
+
+
+ end subroutine strech_diff_penal
+
+
+
+
+ subroutine rotv_df4
+ implicit none
+ integer :: l,m,n,i,j,k
+
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+ real(kind=8) :: facx,facy,facz,dxsca,dysca,dzsca
+
+ !omgx = dy vz - dz vy
+ !omgy = dz vx - dx vz
+ !omgz = dx vy - dy vx
+
+ facx=1.D0/(12.D0*dx)
+ facy=1.D0/(12.D0*dy)
+ facz=1.D0/(12.D0*dz)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ omgx(i,j,k)=facy*(vzg(i,jm2,k)-8.*vzg(i,jm1,k)+8.*vzg(i,jp1,k)-vzg(i,jp2,k)) &
+ -facz*(vyg(i,j,km2)-8.*vyg(i,j,km1)+8.*vyg(i,j,kp1)-vyg(i,j,kp2))
+ omgy(i,j,k)=facz*(vxg(i,j,km2)-8.*vxg(i,j,km1)+8.*vxg(i,j,kp1)-vxg(i,j,kp2)) &
+ -facx*(vzg(im2,j,k)-8.*vzg(im1,j,k)+8.*vzg(ip1,j,k)-vzg(ip2,j,k))
+ omgz(i,j,k)=facx*(vyg(im2,j,k)-8.*vyg(im1,j,k)+8.*vyg(ip1,j,k)-vyg(ip2,j,k)) &
+ -facy*(vxg(i,jm2,k)-8.*vxg(i,jm1,k)+8.*vxg(i,jp1,k)-vxg(i,jp2,k))
+ end do
+ end do
+ end do
+
+ end subroutine rotv_df4
+
+ subroutine rotv_df2
+ implicit none
+ integer :: l,m,n,i,j,k
+
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+ real(kind=8) :: facx,facy,facz,dxsca,dysca,dzsca
+
+ !omgx = dy vz - dz vy
+ !omgy = dz vx - dx vz
+ !omgz = dx vy - dy vx
+
+ facx=1.D0/(2.D0*dx)
+ facy=1.D0/(2.D0*dy)
+ facz=1.D0/(2.D0*dz)
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+
+ omgx(i,j,k)=facy*(-vzg(i,jm1,k)+vzg(i,jp1,k)) &
+ -facz*(-vyg(i,j,km1)+vyg(i,j,kp1))
+ omgy(i,j,k)=facz*(-vxg(i,j,km1)+vxg(i,j,kp1)) &
+ -facx*(-vzg(im1,j,k)+vzg(ip1,j,k))
+ omgz(i,j,k)=facx*(-vyg(im1,j,k)+vyg(ip1,j,k)) &
+ -facy*(-vxg(i,jm1,k)+vxg(i,jp1,k))
+ end do
+ end do
+ end do
+
+ end subroutine rotv_df2
+
+
+
+
+
+
+
+end module old_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/penal_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/penal_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a828611d0a5ce324acd304e0ef48a25e4377c777
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/penal_mod.f90
@@ -0,0 +1,235 @@
+module penal_mod
+ use donnees_mod
+ use tab_mod
+ use nrtype
+ USE nrutil
+ USE nr
+contains
+
+ subroutine make_chi
+ implicit none
+
+ integer :: i,j,k
+ real(kind=8) :: x,y,z,d,rayon,centrex,centrey,centrez,epaisseur !,dist
+
+ do i=1,nx
+ x=xtab(i)
+ do j=1,ny
+ y=ytab(j)
+ do k=1,nz
+ z=ztab(k)
+
+ centrex=0.
+ centrey=0.
+ centrez=0.
+
+ !========================================
+ ! sphere
+ !========================================
+!!$ rayon=0.5
+!!$ d=dist(centrex,centrey,centrez,rayon,x,y,z)
+!!$ chi(i,j,k)=carac(d,0.*dx)
+
+ !========================================
+ ! poiseuil
+ !========================================
+!!$ chi(i,j,k)=0.
+!!$ if ( (z>1.).or.(z<-1.) ) then
+!!$ chi(i,j,k)=1.
+!!$ end if
+
+ !========================================
+ ! poiseuil/Sphere
+ !========================================
+ chi(i,j,k)=0.
+! if ( (y<(1./0.4844)).and.(y>-(1./0.4844)) ) then
+ if ( (y<=0.).and.(y>-(1./0.4844)) ) then
+ !chi(i,j,k)=0.
+ rayon=0.5
+ d=dist(centrex,centrey,centrez,rayon,x,y,z)
+ chi(i,j,k)=carac(d,0.*dx)
+ end if
+
+ chi_sphere(i,j,k)=0.
+! if ( (y<(1./0.4844)).and.(y>-(1./0.4844)) ) then
+ if ( (y<=0.).and.(y>-(1./0.4844)) ) then
+ rayon=0.5
+ d=dist(centrex,centrey,centrez,rayon,x,y,z)
+ chi_sphere(i,j,k)=carac(d,0.*dx)
+ end if
+
+ lambda(i,j,k)=lambda_flu
+ rayon=0.5
+ epaisseur=2*rayon*0.1
+ !dist=sqrt((x-centrex)**2+(y-centrey)**2+(z-centrez)**2)
+ if ( (y<=0.).and.(sqrt((x-centrex)**2+(y-centrey)**2+(z-centrez)**2)<=(rayon-epaisseur)) ) then
+ lambda(i,j,k)=lambda_sol
+ else
+ if ( (y<=0.).and.(sqrt((x-centrex)**2+(y-centrey)**2+(z-centrez)**2)>(rayon-epaisseur)) &
+ .and.(sqrt((x-centrex)**2+(y-centrey)**2+(z-centrez)**2)<=rayon) ) then
+ lambda(i,j,k)=lambda_por
+ end if
+ end if
+
+!!$ !========================================
+!!$ ! rien
+!!$ !========================================
+!!$ chi(i,j,k)=0.
+
+ !========================================
+ ! sphere en dirichlet
+ !========================================
+!!$ chi(i,j,k)=0.
+!!$ if ( (z<2.0645).or.(z>-2.0645) ) then
+!!$ rayon=0.5
+!!$ d=dist(centrex,centrey,centrez,rayon,x,y,z)
+!!$ chi(i,j,k)=carac(d,0.*dx)
+!!$ end if
+
+ end do
+ end do
+ end do
+
+ end subroutine make_chi
+
+
+ function carac(d,eps_c)
+ implicit none
+ real(kind=8),intent(in) :: d,eps_c
+ real(kind=8) :: carac
+ pi=4.*atan(1.0)
+
+ if (d<=-eps_c) carac= 1.
+ if (d>eps_c) carac= 0.
+ if((d<=eps_c).and.(d>-eps_c)) carac=0.5-0.5*d/eps_c-sin(pi*d/eps_c)/(2.*pi)
+
+ !if((d<=eps_c).and.(d>-eps_c)) carac=sin(pi*(eps_c-d)/(4.*eps_c))
+
+ end function carac
+
+ function dist (cx,cy,cz,r,px,py,pz)
+ implicit none
+
+ real(kind=8),intent(in) :: cx,cy,cz,r,px,py,pz
+ real(kind=8) :: dist
+
+ dist=sqrt((cx-px)**2+(py-cy)**2+(pz-cz)**2)-r
+
+ end function dist
+
+
+
+
+ subroutine penal_fft
+ implicit none
+
+ complex(kind=8),dimension(:,:,:),pointer :: sf1x, sf1y, sf1z
+ complex(kind=8),dimension(:,:,:),pointer :: su1x, su1y, su1z
+ complex(kind=8),dimension(:,:),pointer :: sf2x, sf2y, sf2z
+ complex(kind=8),dimension(:,:),pointer :: su2x, su2y, su2z
+
+ integer :: i,j,k,m,n,p
+ real(kind=8) :: fac,x,y,z,l1,l2,l3,kx,ky,kz,r2,coeff,uinfx,uinfy,tmp
+ complex(kind=8) :: coef
+
+
+ l1=(xd-xg)
+ l2=(yh-yb)
+ l3=(zf-zd)
+
+ allocate (sf1x(1:nx/2,1:ny,1:nz),su1x(1:nx/2,1:ny,1:nz) )
+ allocate (sf1y(1:nx/2,1:ny,1:nz),su1y(1:nx/2,1:ny,1:nz) )
+ allocate (sf1z(1:nx/2,1:ny,1:nz),su1z(1:nx/2,1:ny,1:nz) )
+ allocate (sf2x(1:ny,1:nz),su2x(1:ny,1:nz) )
+ allocate (sf2y(1:ny,1:nz),su2y(1:ny,1:nz) )
+ allocate (sf2z(1:ny,1:nz),su2z(1:ny,1:nz) )
+
+
+ !fft forward
+ call rlft3(vxg,sf1x,sf2x,1)
+ call rlft3(vyg,sf1y,sf2y,1)
+ call rlft3(vzg,sf1z,sf2z,1)
+
+ !frequence=0 : n=0
+ !0<f<fc : 1<=n<=N/2-1
+ !f=fc=-fc : n=N/2
+ !-fc<f<0 : N/2+1<=n<=N-1
+
+ fac=2./(nx*ny*nz) ! pour normalisation de la fft inverse
+ coef=-fac*cmplx(0.,1.)*2.*pi
+
+ !calcul de la solution dans l'espace des frequences
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+ do m=1,nx/2
+
+ if ( (m-1)<=(nx/2) ) then
+ kx=(m-1)/l1
+ else
+ kx=(m-1-nx)/l1
+ end if
+
+
+
+ su1x(m,n,p)=coef*(ky*sf1z(m,n,p)-kz*sf1y(m,n,p))
+ su1y(m,n,p)=coef*(kz*sf1x(m,n,p)-kx*sf1z(m,n,p))
+ su1z(m,n,p)=coef*(kx*sf1y(m,n,p)-ky*sf1x(m,n,p))
+
+ end do
+ end do
+ end do
+
+ m=nx/2+1
+ kx=(m-1)/l1
+ do p=1,nz
+ if ( (p-1)<=(nz/2) ) then
+ kz=(p-1)/l3
+ else
+ kz=(p-1-nz)/l3
+ end if
+ do n=1,ny
+
+ if ( (n-1)<=(ny/2) ) then
+ ky=(n-1)/l2
+ else
+ ky=(n-1-ny)/l2
+ end if
+
+
+ su2x(n,p)=coef*(ky*sf2z(n,p)-kz*sf2y(n,p))
+ su2y(n,p)=coef*(kz*sf2x(n,p)-kx*sf2z(n,p))
+ su2z(n,p)=coef*(kx*sf2y(n,p)-ky*sf2x(n,p))
+
+
+
+ end do
+ end do
+
+ !fft backward
+
+ call rlft3(omgx,su1x,su2x,-1)
+ call rlft3(omgy,su1y,su2y,-1)
+ call rlft3(omgz,su1z,su2z,-1)
+
+ deallocate(sf1x,su1x)
+ deallocate(sf1y,su1y)
+ deallocate(sf1z,su1z)
+ deallocate(sf2x,su2x)
+ deallocate(sf2y,su2y)
+ deallocate(sf2z,su2z)
+
+
+ end subroutine penal_fft
+
+
+end module penal_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/remaillage_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/remaillage_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..38b81e05d32c963d4c68b050f79fb03bd0df4afc
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/remaillage_mod.f90
@@ -0,0 +1,1820 @@
+module remaillage_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+ subroutine remaill_l2 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(1:4) :: ip,jp,kp
+ real(kind=8),dimension(1:4) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=1,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=1,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=1,4
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx1<=0.5D0) then
+
+ poidx(1)=-0.5D0*xx1*(1.D0-xx1)
+ poidx(2)=1.D0-xx1**2
+ poidx(3)=0.5D0*xx1*(1.D0+xx1)
+ poidx(4)=0.D0
+
+ else
+
+ poidx(1)=0.D0
+ poidx(2)=0.5D0*(xx1-1.D0)*(xx1-2.D0)
+ poidx(3)=xx1*(2.D0-xx1)
+ poidx(4)=0.5D0*xx1*(xx1-1.D0)
+
+ end if
+
+ if (yy1<=0.5D0) then
+
+ poidy(1)=-0.5D0*yy1*(1.D0-yy1)
+ poidy(2)=1.D0-yy1**2
+ poidy(3)=0.5D0*yy1*(1.D0+yy1)
+ poidy(4)=0.D0
+
+ else
+
+ poidy(1)=0.D0
+ poidy(2)=0.5D0*(yy1-1.D0)*(yy1-2.D0)
+ poidy(3)=yy1*(2.D0-yy1)
+ poidy(4)=0.5D0*yy1*(yy1-1.D0)
+
+ end if
+
+ if (zz1<=0.5D0) then
+
+ poidz(1)=-0.5D0*zz1*(1.D0-zz1)
+ poidz(2)=1.D0-zz1**2
+ poidz(3)=0.5D0*zz1*(1.D0+zz1)
+ poidz(4)=0.D0
+
+ else
+
+ poidz(1)=0.D0
+ poidz(2)=0.5D0*(zz1-1.D0)*(zz1-2.D0)
+ poidz(3)=zz1*(2.D0-zz1)
+ poidz(4)=0.5D0*zz1*(zz1-1.D0)
+
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=1,4
+ do d=1,4
+ do c=1,4
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l2
+
+ subroutine remaill_l4 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:5) :: ip,jp,kp
+ real(kind=8),dimension(0:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(2) - 2
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+ kp(5) = kp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+
+ if (xx1<=0.5D0) then
+ poidx(0)=(2.D0*xx1-x2-2.D0*x3+x4)/24.D0
+ poidx(1)=(-4.D0*xx1+4.D0*x2+x3-x4)/6.D0
+ poidx(2)=1.D0+(-5.D0*x2+x4)/4.D0
+ poidx(3)=(4.D0*xx1+4.D0*x2-x3-x4)/6.D0
+ poidx(4)=(-2.D0*xx1-x2+2.D0*x3+x4)/24.D0
+ poidx(5)=0.D0
+ else
+ poidx(0)=0.D0
+ poidx(1)=(-6.D0*xx1+11.D0*x2-6.D0*x3+x4)/24.D0
+ poidx(2)=1.D0+(-5.D0*xx1-5.D0*x2+5.D0*x3-x4)/6.D0
+ poidx(3)=(6.D0*xx1+x2-4.D0*x3+x4)/4.D0
+ poidx(4)=(-3.D0*xx1+x2+3.D0*x3-x4)/6.D0
+ poidx(5)=(2.D0*xx1-x2-2.D0*x3+x4)/24.D0
+ end if
+
+ if (yy1<=0.5D0) then
+ poidy(0)=(2.D0*yy1-y2-2.D0*y3+y4)/24.D0
+ poidy(1)=(-4.D0*yy1+4.D0*y2+y3-y4)/6.D0
+ poidy(2)=1.D0+(-5.D0*y2+y4)/4.D0
+ poidy(3)=(4.D0*yy1+4.D0*y2-y3-y4)/6.D0
+ poidy(4)=(-2.D0*yy1-y2+2.D0*y3+y4)/24.D0
+ poidy(5)=0.D0
+ else
+ poidy(0)=0.D0
+ poidy(1)=(-6.D0*yy1+11.D0*y2-6.D0*y3+y4)/24.D0
+ poidy(2)=1.D0+(-5.D0*yy1-5.D0*y2+5.D0*y3-y4)/6.D0
+ poidy(3)=(6.D0*yy1+y2-4.D0*y3+y4)/4.D0
+ poidy(4)=(-3.D0*yy1+y2+3.D0*y3-y4)/6.D0
+ poidy(5)=(2.D0*yy1-y2-2.D0*y3+y4)/24.D0
+ end if
+ if (zz1<=0.5D0) then
+ poidz(0)=(2.D0*zz1-z2-2.D0*z3+z4)/24.D0
+ poidz(1)=(-4.D0*zz1+4.D0*z2+z3-z4)/6.D0
+ poidz(2)=1.D0+(-5.D0*z2+z4)/4.D0
+ poidz(3)=(4.D0*zz1+4.D0*z2-z3-z4)/6.D0
+ poidz(4)=(-2.D0*zz1-z2+2.D0*z3+z4)/24.D0
+ poidz(5)=0.D0
+ else
+ poidz(0)=0.D0
+ poidz(1)=(-6.D0*zz1+11.D0*z2-6.D0*z3+z4)/24.D0
+ poidz(2)=1.D0+(-5.D0*zz1-5.D0*z2+5.D0*z3-z4)/6.D0
+ poidz(3)=(6.D0*zz1+z2-4.D0*z3+z4)/4.D0
+ poidz(4)=(-3.D0*zz1+z2+3.D0*z3-z4)/6.D0
+ poidz(5)=(2.D0*zz1-z2-2.D0*z3+z4)/24.D0
+ end if
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,5
+ do d=0,5
+ do c=0,5
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l4
+
+ subroutine remaill_l5 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(0:5) :: ip,jp,kp
+ real(kind=8),dimension(0:5) :: poidx,poidy,poidz
+ real(kind=8) :: xx1,yy1,zz1,x2,x3,x4,x5,y2,y3,y4,y5,z2,z3,z4,z5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+ jp(2) = floor((posy(i)-yb)/dy)
+ jp(0) = jp(2) - 2
+ jp(1) = jp(2) - 1
+ jp(3) = jp(2) + 1
+ jp(4) = jp(2) + 2
+ jp(5) = jp(2) + 3
+
+ kp(2) = floor((posz(i)-zd)/dz)
+ kp(0) = kp(2) - 2
+ kp(1) = kp(2) - 1
+ kp(3) = kp(2) + 1
+ kp(4) = kp(2) + 2
+ kp(5) = kp(2) + 3
+
+
+
+ !distance de la particule à remailler au second point
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+ yy1 = (posy(i) - real(jp(2),kind=8)*dy-yb)/dy
+ zz1 = (posz(i) - real(kp(2),kind=8)*dz-zd)/dz
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=0,5
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=0,5
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+ y2=yy1**2
+ y3=yy1**3
+ y4=yy1**4
+ y5=yy1**5
+ z2=zz1**2
+ z3=zz1**3
+ z4=zz1**4
+ z5=zz1**5
+
+ poidx(0)=xx1/20.D0-x2/24.D0-x3/24.D0+x4/24.D0-x5/120.D0
+ poidx(1)=-xx1/2.D0+2.D0*x2/3.D0-x3/24.D0-x4/6.D0+x5/24.D0
+ poidx(2)=1.D0-xx1/3.D0-5*x2/4.D0+5.D0*x3/12.D0+x4/4.D0-x5/12.D0
+ poidx(3)=xx1+2.D0*x2/3.D0-7.D0*x3/12.D0-x4/6.D0+x5/12.D0
+ poidx(4)=-xx1/4.D0-x2/24.D0+7.D0*x3/24.D0+x4/24.D0-x5/24.D0
+ poidx(5)=xx1/30.D0-x3/24.D0+x5/120.D0
+
+ poidy(0)=yy1/20.D0-y2/24.D0-y3/24.D0+y4/24.D0-y5/120.D0
+ poidy(1)=-yy1/2.D0+2.D0*y2/3.D0-y3/24.D0-y4/6.D0+y5/24.D0
+ poidy(2)=1.D0-yy1/3.D0-5*y2/4.D0+5.D0*y3/12.D0+y4/4.D0-y5/12.D0
+ poidy(3)=yy1+2.D0*y2/3.D0-7.D0*y3/12.D0-y4/6.D0+y5/12.D0
+ poidy(4)=-yy1/4.D0-y2/24.D0+7.D0*y3/24.D0+y4/24.D0-y5/24.D0
+ poidy(5)=yy1/30.D0-y3/24.D0+y5/120.D0
+
+ poidz(0)=zz1/20.D0-z2/24.D0-z3/24.D0+z4/24.D0-z5/120.D0
+ poidz(1)=-zz1/2.D0+2.D0*z2/3.D0-z3/24.D0-z4/6.D0+z5/24.D0
+ poidz(2)=1.D0-zz1/3.D0-5*z2/4.D0+5.D0*z3/12.D0+z4/4.D0-z5/12.D0
+ poidz(3)=zz1+2.D0*z2/3.D0-7.D0*z3/12.D0-z4/6.D0+z5/12.D0
+ poidz(4)=-zz1/4.D0-z2/24.D0+7.D0*z3/24.D0+z4/24.D0-z5/24.D0
+ poidz(5)=zz1/30.D0-z3/24.D0+z5/120.D0
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=0,5
+ do d=0,5
+ do c=0,5
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+ end subroutine remaill_l5
+
+
+ subroutine remaill_l5_x(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posx(i)-xg)/dx)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posx(i) - real(ip(2),kind=8)*dx-xg)/dx
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.D0-x2/24.D0-x3/24.D0+x4/24.D0-x5/120.D0
+ poidx(1)=-xx1/2.D0+2.D0*x2/3.D0-x3/24.D0-x4/6.D0+x5/24.D0
+ poidx(2)=1.D0-xx1/3.D0-5*x2/4.D0+5.D0*x3/12.D0+x4/4.D0-x5/12.D0
+ poidx(3)=xx1+2.D0*x2/3.D0-7.D0*x3/12.D0-x4/6.D0+x5/12.D0
+ poidx(4)=-xx1/4.D0-x2/24.D0+7.D0*x3/24.D0+x4/24.D0-x5/24.D0
+ poidx(5)=xx1/30.D0-x3/24.D0+x5/120.D0
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ip(c)+1,j,kvar)=remaille(ip(c)+1,j,kvar)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_x
+
+
+ subroutine remaill_l5_y(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posy(i)-yb)/dy)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posy(i) - real(ip(2),kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.D0-x2/24.D0-x3/24.D0+x4/24.D0-x5/120.D0
+ poidx(1)=-xx1/2.D0+2.D0*x2/3.D0-x3/24.D0-x4/6.D0+x5/24.D0
+ poidx(2)=1.D0-xx1/3.D0-5*x2/4.D0+5.D0*x3/12.D0+x4/4.D0-x5/12.D0
+ poidx(3)=xx1+2.D0*x2/3.D0-7.D0*x3/12.D0-x4/6.D0+x5/12.D0
+ poidx(4)=-xx1/4.D0-x2/24.D0+7.D0*x3/24.D0+x4/24.D0-x5/24.D0
+ poidx(5)=xx1/30.D0-x3/24.D0+x5/120.D0
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_y
+
+
+ subroutine remaill_l5_z(donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,ivar,k,kvar,jvar
+ integer,dimension(0:5) :: ip
+ real(kind=8),dimension(0:5) :: poidx
+ real(kind=8) :: xx1,x2,x3,x4,x5
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(2) = floor((posz(i)-zd)/dz)
+ ip(0) = ip(2) - 2
+ ip(1) = ip(2) - 1
+ ip(3) = ip(2) + 1
+ ip(4) = ip(2) + 2
+ ip(5) = ip(2) + 3
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx1 = (posz(i) - real(ip(2),kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+
+ !periodique:
+ do c=0,5
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ x2=xx1**2
+ x3=xx1**3
+ x4=xx1**4
+ x5=xx1**5
+
+ poidx(0)=xx1/20.D0-x2/24.D0-x3/24.D0+x4/24.D0-x5/120.D0
+ poidx(1)=-xx1/2.D0+2.D0*x2/3.D0-x3/24.D0-x4/6.D0+x5/24.D0
+ poidx(2)=1.D0-xx1/3.D0-5*x2/4.D0+5.D0*x3/12.D0+x4/4.D0-x5/12.D0
+ poidx(3)=xx1+2.D0*x2/3.D0-7.D0*x3/12.D0-x4/6.D0+x5/12.D0
+ poidx(4)=-xx1/4.D0-x2/24.D0+7.D0*x3/24.D0+x4/24.D0-x5/24.D0
+ poidx(5)=xx1/30.D0-x3/24.D0+x5/120.D0
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=0,5
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l5_z
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ subroutine remaill_l6 (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb
+ integer,dimension(-3:4) :: ip,jp,kp
+ real(kind=8),dimension(-3:4) :: poidx,poidy,poidz
+ real(kind=8) :: xx,yy,zz
+
+ remaille=0.D0
+
+
+ do i=1,npart
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+ jp(0) = floor((posy(i)-yb)/dy)
+ jp(-1) = jp(0) - 1
+ jp(-2) = jp(0) - 2
+ jp(-3) = jp(0) - 3
+ jp(1) = jp(0) + 1
+ jp(2) = jp(0) + 2
+ jp(3) = jp(0) + 3
+ jp(4) = jp(0) + 4
+
+ kp(0) = floor((posz(i)-zd)/dz)
+ kp(-1) = kp(0) - 1
+ kp(-2) = kp(0) - 2
+ kp(-3) = kp(0) - 3
+ kp(1) = kp(0) + 1
+ kp(2) = kp(0) + 2
+ kp(3) = kp(0) + 3
+ kp(4) = kp(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+ yy = (posy(i) - real(jp(0),kind=8)*dy-yb)/dy !relatif
+ zz = (posz(i) - real(kp(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ do c=-3,4
+ jp(c)=mod(jp(c)+ny,ny)
+ end do
+
+ do c=-3,4
+ kp(c)=mod(kp(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5D0) then
+ poidx(-3)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ poidx(-2)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+3.D0)/120.D0
+ poidx(-1)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(0)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/36.D0
+ poidx(1)=(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(2)=-(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/120.D0
+ poidx(3)=(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/720.D0
+ poidx(4)=0.D0
+ else
+ poidx(-3)=0.D0
+ poidx(-2)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)/720.D0
+ poidx(-1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)/120.D0
+ poidx(0)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)/36.D0
+ poidx(2)=(xx-4.D0)*(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(3)=-(xx-4.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/120.D0
+ poidx(4)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ end if
+
+ if (yy<=0.5D0) then
+ poidy(-3)=(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)/720.D0
+ poidy(-2)=-(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+3.D0)/120.D0
+ poidy(-1)=(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+2.D0)*(yy+3.D0)/48.D0
+ poidy(0)=-(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*(yy+1.D0)*(yy+2.D0)*(yy+3.D0)/36.D0
+ poidy(1)=(yy-3.D0)*(yy-2.D0)*yy*(yy+1.D0)*(yy+2.D0)*(yy+3.D0)/48.D0
+ poidy(2)=-(yy-3.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)*(yy+3.D0)/120.D0
+ poidy(3)=(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)*(yy+3.D0)/720.D0
+ poidy(4)=0.D0
+ else
+ poidy(-3)=0.D0
+ poidy(-2)=(yy-4.D0)*(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)/720.D0
+ poidy(-1)=-(yy-4.D0)*(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+2.D0)/120.D0
+ poidy(0)=(yy-4.D0)*(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*(yy+1.D0)*(yy+2.D0)/48.D0
+ poidy(1)=-(yy-4.D0)*(yy-3.D0)*(yy-2.D0)*yy*(yy+1.D0)*(yy+2.D0)/36.D0
+ poidy(2)=(yy-4.D0)*(yy-3.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)/48.D0
+ poidy(3)=-(yy-4.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)/120.D0
+ poidy(4)=(yy-3.D0)*(yy-2.D0)*(yy-1.D0)*yy*(yy+1.D0)*(yy+2.D0)/720.D0
+ end if
+
+ if (zz<=0.5D0) then
+ poidz(-3)=(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)/720.D0
+ poidz(-2)=-(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+3.D0)/120.D0
+ poidz(-1)=(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+2.D0)*(zz+3.D0)/48.D0
+ poidz(0)=-(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*(zz+1.D0)*(zz+2.D0)*(zz+3.D0)/36.D0
+ poidz(1)=(zz-3.D0)*(zz-2.D0)*zz*(zz+1.D0)*(zz+2.D0)*(zz+3.D0)/48.D0
+ poidz(2)=-(zz-3.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)*(zz+3.D0)/120.D0
+ poidz(3)=(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)*(zz+3.D0)/720.D0
+ poidz(4)=0.D0
+ else
+ poidz(-3)=0.D0
+ poidz(-2)=(zz-4.D0)*(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)/720.D0
+ poidz(-1)=-(zz-4.D0)*(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+2.D0)/120.D0
+ poidz(0)=(zz-4.D0)*(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*(zz+1.D0)*(zz+2.D0)/48.D0
+ poidz(1)=-(zz-4.D0)*(zz-3.D0)*(zz-2.D0)*zz*(zz+1.D0)*(zz+2.D0)/36.D0
+ poidz(2)=(zz-4.D0)*(zz-3.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)/48.D0
+ poidz(3)=-(zz-4.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)/120.D0
+ poidz(4)=(zz-3.D0)*(zz-2.D0)*(zz-1.D0)*zz*(zz+1.D0)*(zz+2.D0)/720.D0
+ end if
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do e=-3,4
+ do d=-3,4
+ do c=-3,4
+ remaille(ip(c)+1,jp(d)+1,kp(e)+1)=remaille(ip(c)+1,jp(d)+1,kp(e)+1)+donne(i)*poidx(c)*poidy(d)*poidz(e)
+ end do
+ end do
+ end do
+ end do
+
+ end subroutine remaill_l6
+
+ subroutine remaill_l6_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.D0
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posx(i) - real(ip(0),kind=8)*dx-xg)/dx !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-3,4
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5D0) then
+ poidx(-3)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ poidx(-2)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+3.D0)/120.D0
+ poidx(-1)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(0)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/36.D0
+ poidx(1)=(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(2)=-(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/120.D0
+ poidx(3)=(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/720.D0
+ poidx(4)=0.D0
+ else
+ poidx(-3)=0.D0
+ poidx(-2)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)/720.D0
+ poidx(-1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)/120.D0
+ poidx(0)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)/36.D0
+ poidx(2)=(xx-4.D0)*(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(3)=-(xx-4.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/120.D0
+ poidx(4)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,4
+ remaille(ip(c)+1,jvar,kvar)=remaille(ip(c)+1,jvar,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_x
+
+
+
+ subroutine remaill_l6_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.D0
+
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ kvar=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+
+ xx = (posy(i) - real(ip(0),kind=8)*dy-yb)/dy !relatif
+
+
+
+
+ !conditions au bord
+ !------------------
+
+
+ do c=-3,4
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5D0) then
+ poidx(-3)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ poidx(-2)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+3.D0)/120.D0
+ poidx(-1)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(0)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/36.D0
+ poidx(1)=(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(2)=-(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/120.D0
+ poidx(3)=(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/720.D0
+ poidx(4)=0.D0
+ else
+ poidx(-3)=0.D0
+ poidx(-2)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)/720.D0
+ poidx(-1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)/120.D0
+ poidx(0)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)/36.D0
+ poidx(2)=(xx-4.D0)*(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(3)=-(xx-4.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/120.D0
+ poidx(4)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-3,4
+ remaille(ivar,ip(c)+1,kvar)=remaille(ivar,ip(c)+1,kvar)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_y
+
+ subroutine remaill_l6_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(1:npart),intent(in) :: donne
+ real(kind=8),dimension(1:npart),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,e,ib,jb,kb,ivar,jvar,kvar
+ integer,dimension(-3:4) :: ip
+ real(kind=8),dimension(-3:4) :: poidx
+ real(kind=8) :: xx
+
+ remaille=0.D0
+
+
+ do i=1,npart
+
+ jvar=nint((posy(i)-yb)/dy)+1
+ ivar=nint((posx(i)-xg)/dx)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-1) = ip(0) - 1
+ ip(-2) = ip(0) - 2
+ ip(-3) = ip(0) - 3
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+ ip(4) = ip(0) + 4
+
+
+
+
+
+
+ !distance de la particule à remailler au second point (des quatres utilisés pour le remaillage)
+ !----------------------------------------------------
+ xx = (posz(i) - real(ip(0),kind=8)*dz-zd)/dz !relatif
+
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+
+ do c=-3,4
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+
+ !calcul des poids
+ !----------------
+ if (xx<=0.5D0) then
+ poidx(-3)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ poidx(-2)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+3.D0)/120.D0
+ poidx(-1)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(0)=-(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/36.D0
+ poidx(1)=(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/48.D0
+ poidx(2)=-(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/120.D0
+ poidx(3)=(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/720.D0
+ poidx(4)=0.D0
+ else
+ poidx(-3)=0.D0
+ poidx(-2)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)/720.D0
+ poidx(-1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+2.D0)/120.D0
+ poidx(0)=(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(1)=-(xx-4.D0)*(xx-3.D0)*(xx-2.D0)*xx*(xx+1.D0)*(xx+2.D0)/36.D0
+ poidx(2)=(xx-4.D0)*(xx-3.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/48.D0
+ poidx(3)=-(xx-4.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/120.D0
+ poidx(4)=(xx-3.D0)*(xx-2.D0)*(xx-1.D0)*xx*(xx+1.D0)*(xx+2.D0)/720.D0
+ end if
+
+
+
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+
+ do c=-3,4
+ remaille(ivar,jvar,ip(c)+1)=remaille(ivar,jvar,ip(c)+1)+donne(i)*poidx(c)
+ end do
+
+ end do
+
+ end subroutine remaill_l6_z
+
+
+
+
+ subroutine remaill_l2_bloc_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,k,per
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.D0
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ else
+ poids(0)=0.5D0*(1.D0-xx)*(2.D0-xx)
+ end if
+ case(1)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ case(2)
+ poids(0)=1.D0-0.5D0*xx*(1.D0+xx)
+ case(3)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx
+ case(4)
+ poids(-2)=0.5D0*xx*(1.D0+xx)
+ poids(-1)=-xx
+ poids(0)=1.D0-xx**2
+ case(5)
+ poids(-1)=-0.5D0*xx+0.5D0*xx**2
+ poids(0)=1.D0-poids(-1)
+
+ end select
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ else
+ poids(1)=2.D0*xx-xx**2
+ poids(2)=0.5D0*(xx-1.D0)*xx
+ end if
+ case(1)
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5D0*xx*(xx-1.D0)
+ case(3)
+ poids(1)=3.D0*0.5D0*xx-0.5D0*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_x
+
+
+ subroutine remaill_l2_bloc_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.D0
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ else
+ poids(0)=0.5D0*(1.D0-xx)*(2.D0-xx)
+ end if
+ case(1)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ case(2)
+ poids(0)=1.D0-0.5D0*xx*(1.D0+xx)
+ case(3)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx
+ case(4)
+ poids(-2)=0.5D0*xx*(1.D0+xx)
+ poids(-1)=-xx
+ poids(0)=1.D0-xx**2
+ case(5)
+ poids(-1)=-0.5D0*xx+0.5D0*xx**2
+ poids(0)=1.D0-poids(-1)
+
+ end select
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ else
+ poids(1)=2.D0*xx-xx**2
+ poids(2)=0.5D0*(xx-1.D0)*xx
+ end if
+ case(1)
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5D0*xx*(xx-1.D0)
+ case(3)
+ poids(1)=3.D0*0.5D0*xx-0.5D0*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_y
+
+ subroutine remaill_l2_bloc_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-2:2) :: ip
+ real(kind=8),dimension(-2:2) :: poids
+ real(kind=8) :: xx,tmp_pos
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+ poids=0.D0
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ !periodique:
+ do c=-2,2
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poids
+ !----------------
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ else
+ poids(0)=0.5D0*(1.D0-xx)*(2.D0-xx)
+ end if
+ case(1)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx**2
+ case(2)
+ poids(0)=1.D0-0.5D0*xx*(1.D0+xx)
+ case(3)
+ poids(-1)=0.5D0*xx*(xx-1.D0)
+ poids(0)=1.D0-xx
+ case(4)
+ poids(-2)=0.5D0*xx*(1.D0+xx)
+ poids(-1)=-xx
+ poids(0)=1.D0-xx**2
+ case(5)
+ poids(-1)=-0.5D0*xx+0.5D0*xx**2
+ poids(0)=1.D0-poids(-1)
+
+ end select
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ else
+ poids(1)=2.D0*xx-xx**2
+ poids(2)=0.5D0*(xx-1.D0)*xx
+ end if
+ case(1)
+ poids(1)=0.5D0*xx*(1.D0+xx)
+ case(2)
+ poids(1)=xx
+ poids(2)=0.5D0*xx*(xx-1.D0)
+ case(3)
+ poids(1)=3.D0*0.5D0*xx-0.5D0*xx**2
+ case(4)
+
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-2,2
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l2_bloc_z
+
+
+ subroutine remaill_l4_bloc_x (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,j,per,k
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.D0
+
+
+ do i=1,npart
+
+ j=nint((posy(i)-yb)/dy)+1
+ k=nint((posz(i)-zd)/dz)+1
+ poids=0.D0
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posx(i)-xg)/dx)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posx(i) - real(ip(0) ,kind=8)*dx-xg)/dx
+
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+nx,nx)
+ end do
+
+ !calcul des poids
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+ else
+ t1=(xx-1.D0)*(xx-2.D0)*(xx-3.D0)
+ poids(-1)=t1*xx/24.D0
+ poids(0)=-t1*(xx+1.D0)/6.D0
+ end if
+ case(1)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+
+ case(2)
+ t1=(xx-1.D0)*(xx-2.D0)/12.D0
+ poids(-1)=t1*xx*(xx-3)/2.D0
+ poids(0)=t1*(xx+6.D0)*(xx+1.D0)
+ case(3)
+ t1=0.5D0*(xx-1.D0)*(xx-2.D0)
+ poids(-2)=t1*xx/12.D0*(xx+1.D0)
+ poids(-1)=-t1*xx/3.D0*(xx+2.D0)
+ poids(0)=t1*(xx+1.D0)
+ case(4)
+ t2=(xx**2-1.D0)
+ t1=xx*(xx+2.D0)*0.5D0
+ poids(-3)=t2*t1/12.D0
+ poids(-2)=-t2*xx/6.D0*(xx+3.D0)
+ poids(-1)=t1*(xx-1.D0)
+ poids(0)=t2*(xx**2-4.D0)/4.D0
+ case(5)
+ t1=(xx-2.D0)*(xx-1.D0)/4.D0
+ poids(-1)=-t1*xx/6.D0*(3*xx+7.D0)
+ poids(0)=t1*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1= (xx-1.D0)*(xx-2.D0)/6.D0
+ t2=t1*(xx+1.D0)
+ poids(-2)=t2*xx/4.D0
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.D0)
+ case(7)
+ t1=(xx-1.D0)*(xx+2.D0)
+ t2=xx*(xx+1)/6.D0
+ poids(-3)=t1*t2/4.D0
+ poids(-2)=-t2*(xx-1.D0)
+ poids(-1)=-xx*t1/6.D0*(xx-2.D0)
+ poids(0)=t1*(xx-2.D0)/4.D0*(xx+1.D0)
+ case(8)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=(xx-6.D0)*(xx+2.D0)*(xx**2-1.D0)/12.D0
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ else
+ t1=xx*(xx+1.D0)*(xx-3.D0)
+ poids(1)=t1*(xx-2.D0)/4.D0
+ poids(2)=-t1*(xx-1.D0)/6.D0
+ poids(3)=xx*(xx-2.D0)*(xx**2-1.D0)/24.D0
+ end if
+ case(1)
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ case(2)
+ t1=xx*(xx+1.D0)*0.5D0
+ t2=t1*(xx-1.D0)
+ poids(1)=-t1*(xx-2.D0)
+ poids(2)=-t2/3.D0*(xx-3.D0)
+ poids(3)=t2*(xx-2.D0)/12.D0
+ case(3)
+ t1=xx*(xx+1.D0)/12.D0
+ poids(1)=t1*(xx-2.D0)*(xx-7.D0)
+ poids(2)=t1*(xx+2.D0)*(xx-1.D0)/2.D0
+ case(4)
+ t1=xx*(xx+1.D0)
+ t2=t1*(xx-1.D0)/6.D0
+ poids(1)=-t1*(xx+2.D0)*(xx-2.D0)/6.D0
+ poids(2)=t2
+ poids(3)=t2*(xx-2.D0)/4.D0
+ case(5)
+ poids(1)=-xx/24.D0*(3.D0*xx-7.D0)*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1=xx*(xx+1.D0)/4.D0
+ poids(1)=t1*(xx-3.D0)*(xx-2.D0)
+ poids(2)=-t1*(3.D0*xx-10.D0)*(xx-1.D0)/6.D0
+ case(7)
+ poids(1)=xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/24.D0
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ip(c)+1,j,k)=remaille(ip(c)+1,j,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_x
+
+
+ subroutine remaill_l4_bloc_y (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,k
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ poids=0.D0
+ ivar=nint((posx(i)-xg)/dx)+1
+ k=nint((posz(i)-zd)/dz)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posy(i)-yb)/dy)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posy(i) - real(ip(0) ,kind=8)*dy-yb)/dy
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+ny,ny)
+ end do
+
+ !calcul des poidss
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+ else
+ t1=(xx-1.D0)*(xx-2.D0)*(xx-3.D0)
+ poids(-1)=t1*xx/24.D0
+ poids(0)=-t1*(xx+1.D0)/6.D0
+ end if
+ case(1)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+
+ case(2)
+ t1=(xx-1.D0)*(xx-2.D0)/12.D0
+ poids(-1)=t1*xx*(xx-3)/2.D0
+ poids(0)=t1*(xx+6.D0)*(xx+1.D0)
+ case(3)
+ t1=0.5D0*(xx-1.D0)*(xx-2.D0)
+ poids(-2)=t1*xx/12.D0*(xx+1.D0)
+ poids(-1)=-t1*xx/3.D0*(xx+2.D0)
+ poids(0)=t1*(xx+1.D0)
+ case(4)
+ t2=(xx**2-1.D0)
+ t1=xx*(xx+2.D0)*0.5D0
+ poids(-3)=t2*t1/12.D0
+ poids(-2)=-t2*xx/6.D0*(xx+3.D0)
+ poids(-1)=t1*(xx-1.D0)
+ poids(0)=t2*(xx**2-4.D0)/4.D0
+ case(5)
+ t1=(xx-2.D0)*(xx-1.D0)/4.D0
+ poids(-1)=-t1*xx/6.D0*(3*xx+7.D0)
+ poids(0)=t1*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1= (xx-1.D0)*(xx-2.D0)/6.D0
+ t2=t1*(xx+1.D0)
+ poids(-2)=t2*xx/4.D0
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.D0)
+ case(7)
+ t1=(xx-1.D0)*(xx+2.D0)
+ t2=xx*(xx+1)/6.D0
+ poids(-3)=t1*t2/4.D0
+ poids(-2)=-t2*(xx-1.D0)
+ poids(-1)=-xx*t1/6.D0*(xx-2.D0)
+ poids(0)=t1*(xx-2.D0)/4.D0*(xx+1.D0)
+ case(8)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=(xx-6.D0)*(xx+2.D0)*(xx**2-1.D0)/12.D0
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ else
+ t1=xx*(xx+1.D0)*(xx-3.D0)
+ poids(1)=t1*(xx-2.D0)/4.D0
+ poids(2)=-t1*(xx-1.D0)/6.D0
+ poids(3)=xx*(xx-2.D0)*(xx**2-1.D0)/24.D0
+ end if
+ case(1)
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ case(2)
+ t1=xx*(xx+1.D0)*0.5D0
+ t2=t1*(xx-1.D0)
+ poids(1)=-t1*(xx-2.D0)
+ poids(2)=-t2/3.D0*(xx-3.D0)
+ poids(3)=t2*(xx-2.D0)/12.D0
+ case(3)
+ t1=xx*(xx+1.D0)/12.D0
+ poids(1)=t1*(xx-2.D0)*(xx-7.D0)
+ poids(2)=t1*(xx+2.D0)*(xx-1.D0)/2.D0
+ case(4)
+ t1=xx*(xx+1.D0)
+ t2=t1*(xx-1.D0)/6.D0
+ poids(1)=-t1*(xx+2.D0)*(xx-2.D0)/6.D0
+ poids(2)=t2
+ poids(3)=t2*(xx-2.D0)/4.D0
+ case(5)
+ poids(1)=-xx/24.D0*(3.D0*xx-7.D0)*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1=xx*(xx+1.D0)/4.D0
+ poids(1)=t1*(xx-3.D0)*(xx-2.D0)
+ poids(2)=-t1*(3.D0*xx-10.D0)*(xx-1.D0)/6.D0
+ case(7)
+ poids(1)=xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/24.D0
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ivar,ip(c)+1,k)=remaille(ivar,ip(c)+1,k)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_y
+
+
+ subroutine remaill_l4_bloc_z (donne,posx,posy,posz,remaille)
+ implicit none
+ real(kind=8),dimension(:),intent(in) :: donne
+ real(kind=8),dimension(:),intent(in) :: posx,posy,posz
+ real(kind=8),dimension(1:nx,1:ny,1:nz),intent(out) :: remaille
+ integer :: i,c,d,ib,ivar,per,j
+ integer,dimension(-3:3) :: ip
+ real(kind=8),dimension(-3:3) :: poids
+ real(kind=8) :: xx,tmp_pos,t1,t2,t3
+
+ remaille=0.D0
+
+ do i=1,npart
+
+ poids=0.D0
+ ivar=nint((posx(i)-xg)/dx)+1
+ j=nint((posy(i)-yb)/dy)+1
+
+ !numero des points sur le maillage
+ !--------------------------------
+ ip(0) = floor((posz(i)-zd)/dz)
+ ip(-3) = ip(0) - 3
+ ip(-2) = ip(0) - 2
+ ip(-1) = ip(0) - 1
+ ip(1) = ip(0) + 1
+ ip(2) = ip(0) + 2
+ ip(3) = ip(0) + 3
+
+
+
+ !distance de la particule à remailler au point de grille de gauche
+ !-----------------------------------------------------------------
+ xx = (posz(i) - real(ip(0) ,kind=8)*dz-zd)/dz
+
+ !conditions au bord
+ !------------------
+ do c=-3,3
+ ip(c)=mod(ip(c)+nz,nz)
+ end do
+
+ !calcul des poidss
+ !----------------
+
+
+ select case (blocg(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+ else
+ t1=(xx-1.D0)*(xx-2.D0)*(xx-3.D0)
+ poids(-1)=t1*xx/24.D0
+ poids(0)=-t1*(xx+1.D0)/6.D0
+ end if
+ case(1)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=t2/4.D0*(xx**2-1.D0)
+
+ case(2)
+ t1=(xx-1.D0)*(xx-2.D0)/12.D0
+ poids(-1)=t1*xx*(xx-3)/2.D0
+ poids(0)=t1*(xx+6.D0)*(xx+1.D0)
+ case(3)
+ t1=0.5D0*(xx-1.D0)*(xx-2.D0)
+ poids(-2)=t1*xx/12.D0*(xx+1.D0)
+ poids(-1)=-t1*xx/3.D0*(xx+2.D0)
+ poids(0)=t1*(xx+1.D0)
+ case(4)
+ t2=(xx**2-1.D0)
+ t1=xx*(xx+2.D0)*0.5D0
+ poids(-3)=t2*t1/12.D0
+ poids(-2)=-t2*xx/6.D0*(xx+3.D0)
+ poids(-1)=t1*(xx-1.D0)
+ poids(0)=t2*(xx**2-4.D0)/4.D0
+ case(5)
+ t1=(xx-2.D0)*(xx-1.D0)/4.D0
+ poids(-1)=-t1*xx/6.D0*(3*xx+7.D0)
+ poids(0)=t1*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1= (xx-1.D0)*(xx-2.D0)/6.D0
+ t2=t1*(xx+1.D0)
+ poids(-2)=t2*xx/4.D0
+ poids(-1)=-t1*xx
+ poids(0)=-t2*(xx-3.D0)
+ case(7)
+ t1=(xx-1.D0)*(xx+2.D0)
+ t2=xx*(xx+1)/6.D0
+ poids(-3)=t1*t2/4.D0
+ poids(-2)=-t2*(xx-1.D0)
+ poids(-1)=-xx*t1/6.D0*(xx-2.D0)
+ poids(0)=t1*(xx-2.D0)/4.D0*(xx+1.D0)
+ case(8)
+ t1=xx*(xx-1.D0)
+ t2=xx**2-4.D0
+ poids(-2)=t1/24.D0*(xx-2.D0)*(xx+1.D0)
+ poids(-1)=-t1/6.D0*t2
+ poids(0)=(xx-6.D0)*(xx+2.D0)*(xx**2-1.D0)/12.D0
+ end select
+
+
+
+
+
+ select case (blocd(i))
+
+ case(0)
+ if (xx<=0.5D0) then
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ else
+ t1=xx*(xx+1.D0)*(xx-3.D0)
+ poids(1)=t1*(xx-2.D0)/4.D0
+ poids(2)=-t1*(xx-1.D0)/6.D0
+ poids(3)=xx*(xx-2.D0)*(xx**2-1.D0)/24.D0
+ end if
+ case(1)
+ t1=xx*(xx+1.D0)*(xx+2.D0)
+ poids(1)=-t1*(xx-2.D0)/6.D0
+ poids(2)=t1*(xx-1.D0)/24.D0
+ case(2)
+ t1=xx*(xx+1.D0)*0.5D0
+ t2=t1*(xx-1.D0)
+ poids(1)=-t1*(xx-2.D0)
+ poids(2)=-t2/3.D0*(xx-3.D0)
+ poids(3)=t2*(xx-2.D0)/12.D0
+ case(3)
+ t1=xx*(xx+1.D0)/12.D0
+ poids(1)=t1*(xx-2.D0)*(xx-7.D0)
+ poids(2)=t1*(xx+2.D0)*(xx-1.D0)/2.D0
+ case(4)
+ t1=xx*(xx+1.D0)
+ t2=t1*(xx-1.D0)/6.D0
+ poids(1)=-t1*(xx+2.D0)*(xx-2.D0)/6.D0
+ poids(2)=t2
+ poids(3)=t2*(xx-2.D0)/4.D0
+ case(5)
+ poids(1)=-xx/24.D0*(3.D0*xx-7.D0)*(xx+2.D0)*(xx+1.D0)
+ case(6)
+ t1=xx*(xx+1.D0)/4.D0
+ poids(1)=t1*(xx-3.D0)*(xx-2.D0)
+ poids(2)=-t1*(3.D0*xx-10.D0)*(xx-1.D0)/6.D0
+ case(7)
+ poids(1)=xx*(xx+1.D0)*(xx+2.D0)*(xx+3.D0)/24.D0
+ end select
+
+
+ !remaillage à l' interrieur domaine
+ !---------------------------------
+ do c=-3,3
+ remaille(ivar,j,ip(c)+1)=remaille(ivar,j,ip(c)+1)+donne(i)*poids(c)
+ end do
+
+
+ end do
+
+ end subroutine remaill_l4_bloc_z
+
+
+
+
+
+
+
+
+end module remaillage_mod
+
+
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/resultats_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/resultats_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..464458af0db49b591779591d78ca8326e2713c9d
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/resultats_mod.f90
@@ -0,0 +1,300 @@
+module resultats_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+
+
+
+
+ subroutine res_vtk (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A8)')""
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A15)') "VECTORS omg FLOAT"
+ write(11,'(A20)') "LOOKUP_TABLE DEFAULT"
+
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(f20.9)') real(omgx(i,j,k)),real(omgy(i,j,k)),real(omgz(i,j,k))
+ end do
+ end do
+ end do
+
+ write(11,'(A21)') ""
+ write(11,'(A21)') "VECTORS vitesse FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j,k)),real(vyg(i,j,k)),real(vzg(i,j,k))
+ end do
+ end do
+ end do
+
+ close (11)
+
+ end subroutine res_vtk
+
+
+ subroutine res_vtk_test (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A21)') "VECTORS vg FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j,k)),real(vyg(i,j,k)),real(vzg(i,j,k))
+ end do
+ end do
+ end do
+
+ write(11,'(A21)') "VECTORS omg FLOAT"
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(sqrt(omgx(i,j,k)**2+omgy(i,j,k)**2+omgz(i,j,k)**2)),real(omgy(i,j,k)),real(omgz(i,j,k))
+ end do
+ end do
+ end do
+
+ close (11)
+ end subroutine res_vtk_test
+
+
+ subroutine res_vtk_omgx (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(24,file=nom_fich)
+ WRITE(24,'(A)') "# vtk DataFile Version 3.0"
+ WRITE(24,'(A)') "Scalar"
+ WRITE(24,'(A)') "ASCII"
+ WRITE(24,'(A)') "DATASET STRUCTURED_POINTS"
+ WRITE(24,'(A,I3,A,I3,A,I3)') "DIMENSIONS ",nx," ",ny," ",nz
+ WRITE(24,'(A,A,A,A)') "ORIGIN"," 0"," 0 "," 0"
+ WRITE(24,*) "SPACING"," ",dx," ",dy," ",dz
+ WRITE(24,*) "POINT_DATA ",nx*ny*nz
+ WRITE(24,'(A)') "SCALARS omgx float"
+ WRITE(24,'(A)') "LOOKUP_TABLE DEFAULT"
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(24,*) real(omgx(i,j,k))
+ enddo
+ enddo
+ enddo
+ close(24)
+end subroutine res_vtk_omgx
+
+
+ subroutine res_vtk_nite(nom_fich_omg,nom_fich_vit,nombre_ite,t)
+ implicit none
+ character(len=*),intent(in) :: nom_fich_omg,nom_fich_vit
+ integer,intent(in) :: nombre_ite
+ real(kind=8),intent(in) :: t
+ character(len=60) :: name_vit,name_omg,char_nite
+
+ if (cpt_ite<=20) then
+ write(char_nite,'(I1)') cpt_ite
+ write(name_vit,'(A)') trim(nom_fich_vit)//trim(char_nite)//".vtk"
+ write(name_omg,'(A)') trim(nom_fich_omg)//trim(char_nite)//".vtk"
+ call res_vtk_vit(trim(name_vit))
+ call res_vtk_omega(trim(name_omg))
+ elseif (mod(cpt_ite,40)==0) then
+! if (mod(cpt_ite,nombre_ite)==0) then
+! if (cpt_ite<10) write(char_nite,'(I1)') cpt_ite
+ if ((cpt_ite>9).and.(cpt_ite<100)) write(char_nite,'(I2)') cpt_ite
+ if ((cpt_ite>99).and.(cpt_ite<1000)) write(char_nite,'(I3)') cpt_ite
+ if ((cpt_ite>999).and.(cpt_ite<10000)) write(char_nite,'(I4)') cpt_ite
+ if ((cpt_ite>9999).and.(cpt_ite<100000)) write(char_nite,'(I5)') cpt_ite
+ if ((cpt_ite>99999).and.(cpt_ite<1000000)) write(char_nite,'(I6)') cpt_ite
+ if ((cpt_ite>999999).and.(cpt_ite<10000000)) write(char_nite,'(I7)') cpt_ite
+ write(name_vit,'(A)') trim(nom_fich_vit)//trim(char_nite)//".vtk"
+ write(name_omg,'(A)') trim(nom_fich_omg)//trim(char_nite)//".vtk"
+ call res_vtk_vit(trim(name_vit))
+ call res_vtk_omega(trim(name_omg))
+ end if
+
+ end subroutine res_vtk_nite
+
+ subroutine res_omg_nite(nom_fich_omg,nom_fich_vit,nombre_ite,t)
+ implicit none
+ character(len=*),intent(in) :: nom_fich_omg,nom_fich_vit
+ integer,intent(in) :: nombre_ite
+ real(kind=8),intent(in) :: t
+ character(len=60) :: name_vit,name_omg,char_nite
+
+ if (mod(cpt_ite,nombre_ite)==0) then
+ if (cpt_ite<10) write(char_nite,'(I1)') cpt_ite
+ if ((cpt_ite>9).and.(cpt_ite<100)) write(char_nite,'(I2)') cpt_ite
+ if ((cpt_ite>99).and.(cpt_ite<1000)) write(char_nite,'(I3)') cpt_ite
+ if ((cpt_ite>999).and.(cpt_ite<10000)) write(char_nite,'(I4)') cpt_ite
+ if ((cpt_ite>9999).and.(cpt_ite<100000)) write(char_nite,'(I5)') cpt_ite
+ if ((cpt_ite>99999).and.(cpt_ite<1000000)) write(char_nite,'(I6)') cpt_ite
+ if ((cpt_ite>999999).and.(cpt_ite<10000000)) write(char_nite,'(I7)') cpt_ite
+ write(name_vit,'(A)') trim(nom_fich_vit)//trim(char_nite)//".vtk"
+ write(name_omg,'(A)') trim(nom_fich_omg)//trim(char_nite)//".vtk"
+ call res_vtk_omega(trim(name_omg))
+ end if
+
+ end subroutine res_omg_nite
+
+ subroutine res_vtk_vit (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A21)') "VECTORS vg FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(vxg(i,j,k)),real(vyg(i,j,k)),real(vzg(i,j,k))
+ end do
+ end do
+ end do
+ close (11)
+ end subroutine res_vtk_vit
+
+ subroutine res_vtk_omega (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A21)') "VECTORS omg FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(omgx(i,j,k)),real(omgy(i,j,k)),real(omgz(i,j,k))
+ end do
+ end do
+ end do
+ close (11)
+ end subroutine res_vtk_omega
+
+ subroutine res_vtk_chi (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A21)') "VECTORS chi FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(chi(i,j,k)),real(chi(i,j,k)),real(chi(i,j,k))
+ end do
+ end do
+ end do
+ close (11)
+ end subroutine res_vtk_chi
+
+ subroutine res_vtk_lambda (nom_fich)
+ implicit none
+ character(len=*),intent(in) :: nom_fich
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+
+ open(unit=11,file=nom_fich,form="formatted")
+
+ write(11,'(A26)')"# vtk DataFile Version 3.0"
+ write(11,'(A7)')"vecteur"
+ write(11,'(A5)')"ASCII"
+ write(11,'(A25)')"DATASET STRUCTURED_POINTS"
+ write(11,'(A10,3(i4,1x))')"DIMENSIONS",nx,ny,nz
+ write(11,'(a6,3(f10.5))')"ORIGIN",xg,yb,zd
+ write(11,'(A7,3(f10.5))')"SPACING",dx,dy,dz
+
+
+ write(11,'(A10,i10)') "POINT_DATA",nx*ny*nz
+ write(11,'(A21)') "VECTORS lambda FLOAT"
+
+ do k=1,nz
+ do j=1,ny
+ do i=1,nx
+ write(11,'(3(f20.9))') real(lambda(i,j,k)),real(lambda(i,j,k)),real(lambda(i,j,k))
+ end do
+ end do
+ end do
+ close (11)
+ end subroutine res_vtk_lambda
+
+
+
+
+end module resultats_mod
+
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/rlft2.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/rlft2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9f828ce33da1b670934225246c10703cadb85ccd
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/rlft2.f90
@@ -0,0 +1,52 @@
+ SUBROUTINE rlft2(data,spec,speq,isign)
+ USE nrtype; USE nrutil, ONLY : assert,assert_eq
+ USE nr, ONLY : four2
+ REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: spec
+ COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: speq
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTEGER :: i1,j1,nn1,nn2
+ REAL(DP) :: theta
+ COMPLEX(SPC) :: c1=(0.5_sp,0.0_sp),c2,h1,h2,w
+ COMPLEX(SPC), DIMENSION(size(data,2)-1) :: h1a,h2a
+ COMPLEX(DPC) :: ww,wp
+ nn1=assert_eq(size(data,1),2*size(spec,1),'rlft2: nn1')
+ nn2=assert_eq(size(data,2),size(spec,2),size(speq),'rlft2: nn2')
+ call assert(iand((/nn1,nn2/),(/nn1,nn2/)-1)==0, &
+ 'dimensions must be powers of 2 in rlft2')
+ c2=cmplx(0.0_sp,-0.5_sp*isign,kind=spc)
+ theta=TWOPI_D/(isign*nn1)
+ wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=spc)
+ if (isign == 1) then
+ spec(:,:)=cmplx(data(1:nn1:2,:),data(2:nn1:2,:),kind=spc)
+ call four2(spec,isign)
+ speq=spec(1,:)
+ end if
+ h1=c1*(spec(1,1)+conjg(speq(1)))
+ h1a=c1*(spec(1,2:nn2)+conjg(speq(nn2:2:-1)))
+ h2=c2*(spec(1,1)-conjg(speq(1)))
+ h2a=c2*(spec(1,2:nn2)-conjg(speq(nn2:2:-1)))
+ spec(1,1)=h1+h2
+ spec(1,2:nn2)=h1a+h2a
+ speq(1)=conjg(h1-h2)
+ speq(nn2:2:-1)=conjg(h1a-h2a)
+ ww=cmplx(1.0_dp,0.0_dp,kind=dpc)
+ do i1=2,nn1/4+1
+ j1=nn1/2-i1+2
+ ww=ww*wp+ww
+ w=ww
+ h1=c1*(spec(i1,1)+conjg(spec(j1,1)))
+ h1a=c1*(spec(i1,2:nn2)+conjg(spec(j1,nn2:2:-1)))
+ h2=c2*(spec(i1,1)-conjg(spec(j1,1)))
+ h2a=c2*(spec(i1,2:nn2)-conjg(spec(j1,nn2:2:-1)))
+ spec(i1,1)=h1+w*h2
+ spec(i1,2:nn2)=h1a+w*h2a
+ spec(j1,1)=conjg(h1-w*h2)
+ spec(j1,nn2:2:-1)=conjg(h1a-w*h2a)
+ end do
+ if (isign == -1) then
+ call four2(spec,isign)
+ data(1:nn1:2,:)=real(spec)
+ data(2:nn1:2,:)=aimag(spec)
+ end if
+ END SUBROUTINE rlft2
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/rlft3.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/rlft3.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e0e0e5647bbe3db2c048f1fbf07e0d85346ae09d
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/rlft3.f90
@@ -0,0 +1,70 @@
+ SUBROUTINE rlft3(data,spec,speq,isign)
+ USE nrtype; USE nrutil, ONLY : assert,assert_eq
+ USE nr, ONLY : four3
+ REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data
+ COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: spec
+ COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: speq
+ INTEGER(I4B), INTENT(IN) :: isign
+ INTEGER :: i1,i3,j1,j3,nn1,nn2,nn3
+ REAL(DP) :: theta
+ COMPLEX(SPC) :: c1=(0.5_sp,0.0_sp),c2,h1,h2,w
+ COMPLEX(SPC), DIMENSION(size(data,2)-1) :: h1a,h2a
+ COMPLEX(DPC) :: ww,wp
+
+!!$Given a three-dimensional real array data(1:L,1:M,1:N), this routine returns (for
+!!$isign=1) the complex Fourier transform as two complex arrays: On output, the zero and
+!!$positive frequency values of the first frequency component are in spec(1:L/2,1:M,1:N),
+!!$while speq(1:M,1:N) contains the Nyquist critical frequency values of the first frequency
+!!$component. The second and third frequency components are stored for zero, positive, and
+!!$negative frequencies, in standard wrap-around order. For isign=-1, the inverse transform
+!!$(times L Ã M Ã N/2 as a constant multiplicative factor) is performed, with output data
+!!$deriving from input spec and speq. For inverse transforms on data not generated first by a
+!!$forward transform, make sure the complex input data array satisfies property (12.5.2). The
+!!$size of all arrays must always be integer powers of 2.
+
+
+ c2=cmplx(0.0_sp,-0.5_sp*isign,kind=spc)
+ nn1=assert_eq(size(data,1),2*size(spec,1),'rlft2: nn1')
+ nn2=assert_eq(size(data,2),size(spec,2),size(speq,1),'rlft2: nn2')
+ nn3=assert_eq(size(data,3),size(spec,3),size(speq,2),'rlft2: nn3')
+ call assert(iand((/nn1,nn2,nn3/),(/nn1,nn2,nn3/)-1)==0, &
+ 'dimensions must be powers of 2 in rlft3')
+ theta=TWOPI_D/(isign*nn1)
+ wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
+ if (isign == 1) then
+ spec(:,:,:)=cmplx(data(1:nn1:2,:,:),data(2:nn1:2,:,:),kind=spc)
+ call four3(spec,isign)
+ speq=spec(1,:,:)
+ end if
+ do i3=1,nn3
+ j3=1
+ if (i3 /= 1) j3=nn3-i3+2
+ h1=c1*(spec(1,1,i3)+conjg(speq(1,j3)))
+ h1a=c1*(spec(1,2:nn2,i3)+conjg(speq(nn2:2:-1,j3)))
+ h2=c2*(spec(1,1,i3)-conjg(speq(1,j3)))
+ h2a=c2*(spec(1,2:nn2,i3)-conjg(speq(nn2:2:-1,j3)))
+ spec(1,1,i3)=h1+h2
+ spec(1,2:nn2,i3)=h1a+h2a
+ speq(1,j3)=conjg(h1-h2)
+ speq(nn2:2:-1,j3)=conjg(h1a-h2a)
+ ww=cmplx(1.0_dp,0.0_dp,kind=dpc)
+ do i1=2,nn1/4+1
+ j1=nn1/2-i1+2
+ ww=ww*wp+ww
+ w=ww
+ h1=c1*(spec(i1,1,i3)+conjg(spec(j1,1,j3)))
+ h1a=c1*(spec(i1,2:nn2,i3)+conjg(spec(j1,nn2:2:-1,j3)))
+ h2=c2*(spec(i1,1,i3)-conjg(spec(j1,1,j3)))
+ h2a=c2*(spec(i1,2:nn2,i3)-conjg(spec(j1,nn2:2:-1,j3)))
+ spec(i1,1,i3)=h1+w*h2
+ spec(i1,2:nn2,i3)=h1a+w*h2a
+ spec(j1,1,j3)=conjg(h1-w*h2)
+ spec(j1,nn2:2:-1,j3)=conjg(h1a-w*h2a)
+ end do
+ end do
+ if (isign == -1) then
+ call four3(spec,isign)
+ data(1:nn1:2,:,:)=real(spec)
+ data(2:nn1:2,:,:)=aimag(spec)
+ end if
+ END SUBROUTINE rlft3
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/source_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/source_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c7ac16acac59dbd1a7cba06559bc7cfe6f1e5431
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/source_mod.f90
@@ -0,0 +1,521 @@
+module source_mod
+ use donnees_mod
+ use tab_mod
+
+contains
+
+ !resolution du terme source :
+ !div(u:omega)+Delta(omega)/Re+rot(v*exp(-lambda*chi*dt))
+ !par DF d'ordre4 decentre sur les bords
+
+ subroutine source_split_1
+ implicit none
+ integer :: i
+ real(kind=8),dimension(1:3) :: ts,tsa
+
+ !ordre2
+ !------
+ do i=1,npart
+ !qp(i)=qp(i)+0.5D0*dt*tsource(time,xp(i),yp(i),zp(i))
+
+ ts=strech( nint((xp(i)-xg)/dx+1),nint((yp(i)-yb)/dy+1),nint((zp(i)-zd)/dz+1) )&
+ +nu*diffusion( nint((xp(i)-xg)/dx+1),nint((yp(i)-yb)/dy+1),nint((zp(i)-zd)/dz+1) )&
+ +penal( nint((xp(i)-xg)/dx+1),nint((yp(i)-yb)/dy+1),nint((zp(i)-zd)/dz+1) )
+
+ !call source_anal(tsa, xp(i),yp(i),zp(i) )
+
+ !omx(i)=omx(i)+0.5D0*dt*(ts(1)+tsa(1))
+ !omy(i)=omy(i)+0.5D0*dt*(ts(2)+tsa(2))
+ !omz(i)=omz(i)+0.5D0*dt*(ts(3)+tsa(3))
+
+ omx(i)=omx(i)+0.5*dt*ts(1)
+ omy(i)=omy(i)+0.5*dt*ts(2)
+ omz(i)=omz(i)+0.5*dt*ts(3)
+
+ end do
+
+ end subroutine source_split_1
+
+ subroutine source_split_2
+ implicit none
+ integer :: i,j,k
+ real(kind=8) :: x,y,z
+ real(kind=8),dimension(1:3) :: ts,tsa
+ real(kind=8),dimension(:,:,:),pointer :: omgx_tmp,omgy_tmp,omgz_tmp
+
+ real(kind=8) :: cx,c2x,cy,c2y,cz,c2z,sx,s2x,sy,s2y,sz,s2z,ct,st,c2t,s2t
+
+ allocate(omgx_tmp(1:nx,1:ny,1:nz),omgy_tmp(1:nx,1:ny,1:nz),omgz_tmp(1:nx,1:ny,1:nz))
+ omgx_tmp=0.
+ omgy_tmp=0.
+ omgz_tmp=0.
+
+ !ordre2
+ !------
+ do k=1,nz
+ z=ztab(k)
+ do j=1,ny
+ y=ytab(j)
+ do i=1,nx
+ x=xtab(i)
+
+ !qg(i,j,k)=qg(i,j,k)+0.5D0*dt*tsource(time+dt,x,y,z)
+
+ ts=strech(i,j,k)+nu*diffusion(i,j,k)+penal(i,j,k)
+
+ !call source_anal(tsa,x,y,z)
+
+
+ !pour l'instant en t
+ !omgx_tmp(i,j,k)=omgx_tmp(i,j,k)+0.5D0*dt*(ts(1)+tsa(1))
+ !omgy_tmp(i,j,k)=omgy_tmp(i,j,k)+0.5D0*dt*(ts(2)+tsa(2))
+ !omgz_tmp(i,j,k)=omgz_tmp(i,j,k)+0.5D0*dt*(ts(3)+tsa(3))
+
+ omgx_tmp(i,j,k)=omgx_tmp(i,j,k)+0.5D0*dt*ts(1)
+ omgy_tmp(i,j,k)=omgy_tmp(i,j,k)+0.5D0*dt*ts(2)
+ omgz_tmp(i,j,k)=omgz_tmp(i,j,k)+0.5D0*dt*ts(3)
+
+
+
+ end do
+ end do
+ end do
+
+ omgx=omgx+omgx_tmp
+ omgy=omgy+omgy_tmp
+ omgz=omgz+omgz_tmp
+
+ deallocate(omgx_tmp,omgy_tmp,omgz_tmp)
+
+
+ end subroutine source_split_2
+
+
+
+ function strech (i,j,k)
+ implicit none
+ real(kind=8),dimension(1:3) :: strech
+ integer,intent(in) :: i,j,k
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ real(kind=8) :: facx,facy,facz
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+
+ !forme conservative : div(w:u)
+
+ facx=1.D0/(12.D0*dx)
+ facy=1.D0/(12.D0*dy)
+ facz=1.D0/(12.D0*dz)
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ !conditions periodiques
+ !-----------------------
+ tx(1)=facx*(omgx(im2,j,k)*vxg(im2,j,k)-8.D0*omgx(im1,j,k)*vxg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vxg(ip1,j,k)-omgx(ip2,j,k)*vxg(ip2,j,k))
+ tx(2)=facx*(omgx(im2,j,k)*vyg(im2,j,k)-8.D0*omgx(im1,j,k)*vyg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vyg(ip1,j,k)-omgx(ip2,j,k)*vyg(ip2,j,k))
+ tx(3)=facx*(omgx(im2,j,k)*vzg(im2,j,k)-8.D0*omgx(im1,j,k)*vzg(im1,j,k) &
+ +8.D0*omgx(ip1,j,k)*vzg(ip1,j,k)-omgx(ip2,j,k)*vzg(ip2,j,k))
+
+ ty(1)=facy*(omgy(i,jm2,k)*vxg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vxg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vxg(i,jp1,k)-omgy(i,jp2,k)*vxg(i,jp2,k))
+ ty(2)=facy*(omgy(i,jm2,k)*vyg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vyg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vyg(i,jp1,k)-omgy(i,jp2,k)*vyg(i,jp2,k))
+ ty(3)=facy*(omgy(i,jm2,k)*vzg(i,jm2,k)-8.D0*omgy(i,jm1,k)*vzg(i,jm1,k) &
+ +8.D0*omgy(i,jp1,k)*vzg(i,jp1,k)-omgy(i,jp2,k)*vzg(i,jp2,k))
+
+ tz(1)=facz*(omgz(i,j,km2)*vxg(i,j,km2)-8.D0*omgz(i,j,km1)*vxg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vxg(i,j,kp1)-omgz(i,j,kp2)*vxg(i,j,kp2))
+ tz(2)=facz*(omgz(i,j,km2)*vyg(i,j,km2)-8.D0*omgz(i,j,km1)*vyg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vyg(i,j,kp1)-omgz(i,j,kp2)*vyg(i,j,kp2))
+ tz(3)=facz*(omgz(i,j,km2)*vzg(i,j,km2)-8.D0*omgz(i,j,km1)*vzg(i,j,km1) &
+ +8.D0*omgz(i,j,kp1)*vzg(i,j,kp1)-omgz(i,j,kp2)*vzg(i,j,kp2))
+
+ !conditions non periodiques
+ !--------------------------
+!!$ if((i/=1).and.(i/=2).and.(i/=nx).and.(i/=nx-1).and.(j/=1).and.(j/=2).and.(j/=ny).and.(j/=ny-1).and.(k/=1).and.(k/=2).and.(k/=nz).and.(k/=nz-1))then
+!!$ !schema centre d'ordre4
+!!$
+!!$ tx(1)=facx*(omgx(i-2,j,k)*vxg(i-2,j,k)-8.D0*omgx(i-1,j,k)*vxg(i-1,j,k)+8.D0*omgx(i+1,j,k)*vxg(i+1,j,k)-omgx(i+2,j,k)*vxg(i+2,j,k))
+!!$ tx(2)=facx*(omgx(i-2,j,k)*vyg(i-2,j,k)-8.D0*omgx(i-1,j,k)*vyg(i-1,j,k)+8.D0*omgx(i+1,j,k)*vyg(i+1,j,k)-omgx(i+2,j,k)*vyg(i+2,j,k))
+!!$ tx(3)=facx*(omgx(i-2,j,k)*vzg(i-2,j,k)-8.D0*omgx(i-1,j,k)*vzg(i-1,j,k)+8.D0*omgx(i+1,j,k)*vzg(i+1,j,k)-omgx(i+2,j,k)*vzg(i+2,j,k))
+!!$
+!!$ ty(1)=facy*(omgy(i,j-2,k)*vxg(i,j-2,k)-8.D0*omgy(i,j-1,k)*vxg(i,j-1,k)+8.D0*omgy(i,j+1,k)*vxg(i,j+1,k)-omgy(i,j+2,k)*vxg(i,j+2,k))
+!!$ ty(2)=facy*(omgy(i,j-2,k)*vyg(i,j-2,k)-8.D0*omgy(i,j-1,k)*vyg(i,j-1,k)+8.D0*omgy(i,j+1,k)*vyg(i,j+1,k)-omgy(i,j+2,k)*vyg(i,j+2,k))
+!!$ ty(3)=facy*(omgy(i,j-2,k)*vzg(i,j-2,k)-8.D0*omgy(i,j-1,k)*vzg(i,j-1,k)+8.D0*omgy(i,j+1,k)*vzg(i,j+1,k)-omgy(i,j+2,k)*vzg(i,j+2,k))
+!!$
+!!$ tz(1)=facz*(omgz(i,j,k-2)*vxg(i,j,k-2)-8.D0*omgz(i,j,k-1)*vxg(i,j,k-1)+8.D0*omgz(i,j,k+1)*vxg(i,j,k+1)-omgz(i,j,k+2)*vxg(i,j,k+2))
+!!$ tz(2)=facz*(omgz(i,j,k-2)*vyg(i,j,k-2)-8.D0*omgz(i,j,k-1)*vyg(i,j,k-1)+8.D0*omgz(i,j,k+1)*vyg(i,j,k+1)-omgz(i,j,k+2)*vyg(i,j,k+2))
+!!$ tz(3)=facz*(omgz(i,j,k-2)*vzg(i,j,k-2)-8.D0*omgz(i,j,k-1)*vzg(i,j,k-1)+8.D0*omgz(i,j,k+1)*vzg(i,j,k+1)-omgz(i,j,k+2)*vzg(i,j,k+2))
+!!$
+!!$ else
+!!$
+!!$ !schema decentre au bord (ordre4)
+!!$ if((i==1).or.(i==2))then
+!!$ tx(1)=facx*(-25.D0*omgx(i,j,k)*vxg(i,j,k)+48.D0*omgx(i+1,j,k)*vxg(i+1,j,k)-36.D0*omgx(i+2,j,k)*vxg(i+2,j,k)+16.D0*omgx(i+3,j,k)*vxg(i+3,j,k)-3.D0*omgx(i+4,j,k)*vxg(i+4,j,k))
+!!$ tx(2)=facx*(-25.D0*omgx(i,j,k)*vyg(i,j,k)+48.D0*omgx(i+1,j,k)*vyg(i+1,j,k)-36.D0*omgx(i+2,j,k)*vyg(i+2,j,k)+16.D0*omgx(i+3,j,k)*vyg(i+3,j,k)-3.D0*omgx(i+4,j,k)*vyg(i+4,j,k))
+!!$ tx(3)=facx*(-25.D0*omgx(i,j,k)*vzg(i,j,k)+48.D0*omgx(i+1,j,k)*vzg(i+1,j,k)-36.D0*omgx(i+2,j,k)*vzg(i+2,j,k)+16.D0*omgx(i+3,j,k)*vzg(i+3,j,k)-3.D0*omgx(i+4,j,k)*vzg(i+4,j,k))
+!!$ end if
+!!$
+!!$ if((i==nx).or.(i==nx-1))then
+!!$ tx(1)=facx*(-25.D0*omgx(i,j,k)*vxg(i,j,k)+48.D0*omgx(i-1,j,k)*vxg(i-1,j,k)-36.D0*omgx(i-2,j,k)*vxg(i-2,j,k)+16.D0*omgx(i-3,j,k)*vxg(i-3,j,k)-3.D0*omgx(i-4,j,k)*vxg(i-4,j,k))
+!!$ tx(2)=facx*(-25.D0*omgx(i,j,k)*vyg(i,j,k)+48.D0*omgx(i-1,j,k)*vyg(i-1,j,k)-36.D0*omgx(i-2,j,k)*vyg(i-2,j,k)+16.D0*omgx(i-3,j,k)*vyg(i-3,j,k)-3.D0*omgx(i-4,j,k)*vyg(i-4,j,k))
+!!$ tx(3)=facx*(-25.D0*omgx(i,j,k)*vzg(i,j,k)+48.D0*omgx(i-1,j,k)*vzg(i-1,j,k)-36.D0*omgx(i-2,j,k)*vzg(i-2,j,k)+16.D0*omgx(i-3,j,k)*vzg(i-3,j,k)-3.D0*omgx(i-4,j,k)*vzg(i-4,j,k))
+!!$ endif
+!!$
+!!$ if((j==1).or.(j==2))then
+!!$ ty(1)=facy*(-25.D0*omgy(i,j,k)*vxg(i,j,k)+48.D0*omgy(i,j+1,k)*vxg(i,j+1,k)-36.D0*omgy(i,j+2,k)*vxg(i,j+2,k)+16.D0*omgy(i,j+3,k)*vxg(i,j+3,k)-3.D0*omgy(i,j+4,k)*vxg(i,j+4,k))
+!!$ ty(2)=facy*(-25.D0*omgy(i,j,k)*vyg(i,j,k)+48.D0*omgy(i,j+1,k)*vyg(i,j+1,k)-36.D0*omgy(i,j+2,k)*vyg(i,j+2,k)+16.D0*omgy(i,j+3,k)*vyg(i,j+3,k)-3.D0*omgy(i,j+4,k)*vyg(i,j+4,k))
+!!$ ty(3)=facy*(-25.D0*omgy(i,j,k)*vzg(i,j,k)+48.D0*omgy(i,j+1,k)*vzg(i,j+1,k)-36.D0*omgy(i,j+2,k)*vzg(i,j+2,k)+16.D0*omgy(i,j+3,k)*vzg(i,j+3,k)-3.D0*omgy(i,j+4,k)*vzg(i,j+4,k))
+!!$ end if
+!!$
+!!$ if((j==ny).or.(j==ny-1))then
+!!$ ty(1)=facy*(-25.D0*omgy(i,j,k)*vxg(i,j,k)+48.D0*omgy(i,j-1,k)*vxg(i,j-1,k)-36.D0*omgy(i,j-2,k)*vxg(i,j-2,k)+16.D0*omgy(i,j-3,k)*vxg(i,j-3,k)-3.D0*omgy(i,j-4,k)*vxg(i,j-4,k))
+!!$ ty(2)=facy*(-25.D0*omgy(i,j,k)*vyg(i,j,k)+48.D0*omgy(i,j-1,k)*vyg(i,j-1,k)-36.D0*omgy(i,j-2,k)*vyg(i,j-2,k)+16.D0*omgy(i,j-3,k)*vyg(i,j-3,k)-3.D0*omgy(i,j-4,k)*vyg(i,j-4,k))
+!!$ ty(3)=facy*(-25.D0*omgy(i,j,k)*vzg(i,j,k)+48.D0*omgy(i,j-1,k)*vzg(i,j-1,k)-36.D0*omgy(i,j-2,k)*vzg(i,j-2,k)+16.D0*omgy(i,j-3,k)*vzg(i,j-3,k)-3.D0*omgy(i,j-4,k)*vzg(i,j-4,k))
+!!$ endif
+!!$
+!!$ if((k==1).or.(k==2))then
+!!$ tz(1)=facz*(-25.D0*omgz(i,j,k)*vxg(i,j,k)+48.D0*omgz(i,j,k+1)*vxg(i,j,k+1)-36.D0*omgz(i,j,k+2)*vxg(i,j,k+2)+16.D0*omgz(i,j,k+3)*vxg(i,j,k+3)-3.D0*omgz(i,j,k+4)*vxg(i,j,k+4))
+!!$ tz(2)=facz*(-25.D0*omgz(i,j,k)*vyg(i,j,k)+48.D0*omgz(i,j,k+1)*vyg(i,j,k+1)-36.D0*omgz(i,j,k+2)*vyg(i,j,k+2)+16.D0*omgz(i,j,k+3)*vyg(i,j,k+3)-3.D0*omgz(i,j,k+4)*vyg(i,j,k+4))
+!!$ tz(3)=facz*(-25.D0*omgz(i,j,k)*vzg(i,j,k)+48.D0*omgz(i,j,k+1)*vzg(i,j,k+1)-36.D0*omgz(i,j,k+2)*vzg(i,j,k+2)+16.D0*omgz(i,j,k+3)*vzg(i,j,k+3)-3.D0*omgz(i,j,k+4)*vzg(i,j,k+4))
+!!$ end if
+!!$
+!!$ if((k==nz).or.(k==nz-1))then
+!!$ tz(1)=facz*(-25.D0*omgz(i,j,k)*vxg(i,j,k)+48.D0*omgz(i,j,k-1)*vxg(i,j,k-1)-36.D0*omgz(i,j,k-2)*vxg(i,j,k-2)+16.D0*omgz(i,j,k-3)*vxg(i,j,k-3)-3.D0*omgz(i,j,k-4)*vxg(i,j,k-4))
+!!$ tz(2)=facz*(-25.D0*omgz(i,j,k)*vyg(i,j,k)+48.D0*omgz(i,j,k-1)*vyg(i,j,k-1)-36.D0*omgz(i,j,k-2)*vyg(i,j,k-2)+16.D0*omgz(i,j,k-3)*vyg(i,j,k-3)-3.D0*omgz(i,j,k-4)*vyg(i,j,k-4))
+!!$ tz(3)=facz*(-25.D0*omgz(i,j,k)*vzg(i,j,k)+48.D0*omgz(i,j,k-1)*vzg(i,j,k-1)-36.D0*omgz(i,j,k-2)*vzg(i,j,k-2)+16.D0*omgz(i,j,k-3)*vzg(i,j,k-3)-3.D0*omgz(i,j,k-4)*vzg(i,j,k-4))
+!!$ endif
+!!$
+!!$ end if
+
+ strech(1)=tx(1)+ty(1)+tz(1)
+ strech(2)=tx(2)+ty(2)+tz(2)
+ strech(3)=tx(3)+ty(3)+tz(3)
+
+ end function strech
+
+
+ function diffusion (i,j,k)
+ implicit none
+ real(kind=8),dimension(1:3) :: diffusion
+ integer,intent(in) :: i,j,k
+ real(kind=8) :: facx,facy,facz
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+
+ facx=1.D0/(12.D0*dx**2)
+ facy=1.D0/(12.D0*dy**2)
+ facz=1.D0/(12.D0*dz**2)
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ !ordre4
+ tx(1)=facx*(-omgx(ip2,j,k)+16.D0*omgx(ip1,j,k)-30.D0*omgx(i,j,k)+16.D0*omgx(im1,j,k)-omgx(im2,j,k))
+ tx(2)=facx*(-omgy(ip2,j,k)+16.D0*omgy(ip1,j,k)-30.D0*omgy(i,j,k)+16.D0*omgy(im1,j,k)-omgy(im2,j,k))
+ tx(3)=facx*(-omgz(ip2,j,k)+16.D0*omgz(ip1,j,k)-30.D0*omgz(i,j,k)+16.D0*omgz(im1,j,k)-omgz(im2,j,k))
+
+ ty(1)=facy*(-omgx(i,jp2,k)+16.D0*omgx(i,jp1,k)-30.D0*omgx(i,j,k)+16.D0*omgx(i,jm1,k)-omgx(i,jm2,k))
+ ty(2)=facy*(-omgy(i,jp2,k)+16.D0*omgy(i,jp1,k)-30.D0*omgy(i,j,k)+16.D0*omgy(i,jm1,k)-omgy(i,jm2,k))
+ ty(3)=facy*(-omgz(i,jp2,k)+16.D0*omgz(i,jp1,k)-30.D0*omgz(i,j,k)+16.D0*omgz(i,jm1,k)-omgz(i,jm2,k))
+
+ tz(1)=facz*(-omgx(i,j,kp2)+16.D0*omgx(i,j,kp1)-30.D0*omgx(i,j,k)+16.D0*omgx(i,j,km1)-omgx(i,j,km2))
+ tz(2)=facz*(-omgy(i,j,kp2)+16.D0*omgy(i,j,kp1)-30.D0*omgy(i,j,k)+16.D0*omgy(i,j,km1)-omgy(i,j,km2))
+ tz(3)=facz*(-omgz(i,j,kp2)+16.D0*omgz(i,j,kp1)-30.D0*omgz(i,j,k)+16.D0*omgz(i,j,km1)-omgz(i,j,km2))
+!!$
+!!$ !ordre2
+!!$ facx=1.D0/(dx**2)
+!!$ facy=1.D0/(dy**2)
+!!$ facz=1.D0/(dz**2)
+!!$
+!!$ tx(1)=facx*(omgx(ip1,j,k)-2.*omgx(i,j,k)+omgx(im1,j,k))
+!!$ tx(2)=facx*(omgy(ip1,j,k)-2.*omgy(i,j,k)+omgy(im1,j,k))
+!!$ tx(3)=facx*(omgz(ip1,j,k)-2.*omgz(i,j,k)+omgz(im1,j,k))
+!!$
+!!$ ty(1)=facy*(omgx(i,jp1,k)-2.*omgx(i,j,k)+omgx(i,jm1,k))
+!!$ ty(2)=facy*(omgy(i,jp1,k)-2.*omgy(i,j,k)+omgy(i,jm1,k))
+!!$ ty(3)=facy*(omgz(i,jp1,k)-2.*omgz(i,j,k)+omgz(i,jm1,k))
+!!$
+!!$ tz(1)=facz*(omgx(i,j,kp1)-2.*omgx(i,j,k)+omgx(i,j,km1))
+!!$ tz(2)=facz*(omgy(i,j,kp1)-2.*omgy(i,j,k)+omgy(i,j,km1))
+!!$ tz(3)=facz*(omgz(i,j,kp1)-2.*omgz(i,j,k)+omgz(i,j,km1))
+
+
+
+ diffusion(1)=tx(1)+ty(1)+tz(1)
+ diffusion(2)=tx(2)+ty(2)+tz(2)
+ diffusion(3)=tx(3)+ty(3)+tz(3)
+
+
+ end function diffusion
+
+
+
+
+
+
+
+
+
+ function penal(i,j,k)
+ implicit none
+ real(kind=8),dimension(1:3) :: penal
+ integer,intent(in) :: i,j,k
+ real(kind=8),dimension(1:3) :: tx,ty,tz
+ real(kind=8) :: facx,facy,facz
+ integer :: ip1,ip2,im1,im2,jp1,jp2,jm1,jm2,kp1,kp2,km1,km2
+
+ !forme conservative : div(w:u)
+
+ facx=1.D0/(12.D0*dx)
+ facy=1.D0/(12.D0*dy)
+ facz=1.D0/(12.D0*dz)
+
+ ip1=mod(i+1+nx-1,nx)+1
+ im1=mod(i-1+nx-1,nx)+1
+ ip2=mod(i+2+nx-1,nx)+1
+ im2=mod(i-2+nx-1,nx)+1
+
+ jp1=mod(j+1+ny-1,ny)+1
+ jm1=mod(j-1+ny-1,ny)+1
+ jp2=mod(j+2+ny-1,ny)+1
+ jm2=mod(j-2+ny-1,ny)+1
+
+ kp1=mod(k+1+nz-1,nz)+1
+ km1=mod(k-1+nz-1,nz)+1
+ kp2=mod(k+2+nz-1,nz)+1
+ km2=mod(k-2+nz-1,nz)+1
+
+ !conditions periodiques
+ !-----------------------
+
+ tx(2)=facx*(peny(im2,j,k)-8.D0*peny(im1,j,k)+8.D0*peny(ip1,j,k)-peny(ip2,j,k))
+ tx(3)=facx*(penz(im2,j,k)-8.D0*penz(im1,j,k)+8.D0*penz(ip1,j,k)-penz(ip2,j,k))
+
+ ty(1)=facy*(penx(i,jm2,k)-8.D0*penx(i,jm1,k)+8.D0*penx(i,jp1,k)-penx(i,jp2,k))
+ ty(3)=facy*(penz(i,jm2,k)-8.D0*penz(i,jm1,k)+8.D0*penz(i,jp1,k)-penz(i,jp2,k))
+
+
+ tz(1)=facz*(penx(i,j,km2)-8.D0*penx(i,j,km1)+8.D0*penx(i,j,kp1)-penx(i,j,kp2))
+ tz(2)=facz*(peny(i,j,km2)-8.D0*peny(i,j,km1)+8.D0*peny(i,j,kp1)-peny(i,j,kp2))
+
+
+ penal(1)=ty(3)-tz(2)
+ penal(2)=tz(1)-tx(3)
+ penal(3)=tx(2)-ty(1)
+
+ contains
+ function penx (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penx
+
+
+ !penx=vxg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ !penx=vxg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+
+ !explicite
+ !penx=-lambda*chi(l,m,n)*vxg(l,m,n)
+ penx=vxg(l,m,n)
+
+ end function penx
+
+ function peny (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: peny
+
+
+ !peny=vyg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ !peny=vyg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+
+ !explicite
+ !peny=-lambda*chi(l,m,n)*vyg(l,m,n)
+ peny=vyg(l,m,n)
+
+ end function peny
+
+ function penz (l,m,n)
+ implicit none
+ integer, intent(in) :: l,m,n
+ real(kind=8) :: penz
+
+
+ !penz=vzg(l,m,n)*exp(-lambda*chi(l,m,n)*dt)
+ !penz=vzg(l,m,n)/(1.+lambda*chi(l,m,n)*dt)
+
+ !explicite
+ !penz=-lambda*chi(l,m,n)*vzg(l,m,n)
+ penz=vzg(l,m,n)
+
+ end function penz
+
+ end function penal
+
+
+
+
+
+
+ subroutine source_anal (s,x,y,z)
+ !pour test terme source pour sol de NS
+ implicit none
+ real(kind=8),dimension(1:3),intent(out) :: s
+ real(kind=8),intent(in) :: x,y,z
+ real(kind=8) :: cx,c2x,cy,c2y,cz,c2z,sx,s2x,sy,s2y,sz,s2z,ct,st,c2t,s2t
+
+ real(kind=8) :: t1,t2,t3,c1,c2,c3
+
+
+ !=================
+ !sur [0,1]**3
+ !=================
+
+ cx=cos(pi*x)
+ c2x=cos(2.*pi*x)
+ sx=sin(pi*x)
+ s2x=sin(2.*pi*x)
+
+ cy=cos(pi*y)
+ c2y=cos(2.*pi*y)
+ sy=sin(pi*y)
+ s2y=sin(2.*pi*y)
+
+ cz=cos(pi*z)
+ c2z=cos(2.*pi*z)
+ sz=sin(pi*z)
+ s2z=sin(2.*pi*z)
+
+ ct=cos(pi*time)
+ c2t=cos(2.*pi*time)
+ st=sin(pi*time)
+ s2t=sin(2.*pi*time)
+
+ !sol analytique instationnaire
+ !-----------------------------
+!!$ s(1)=2.*pi**2*(s2x*c2y*sz**2*st&
+!!$ -s2x*sy**2*c2z*st&
+!!$ -8.*sx**2*s2y*s2z*ct**2*c2x*c2y*sz**2&
+!!$ +8.*sx**2*s2y*s2z*ct**2*c2x*sy**2*c2z&
+!!$ -2.*s2x**2*sy**3*s2z*ct**2*c2z*cy&
+!!$ +2.*s2x**2*s2y*sz**3*ct**2*c2y*cz&
+!!$ +4.*sx*s2y*s2z*ct**2*cx*s2x*c2y*sz**2&
+!!$ -4.*sx*s2y*s2z*ct**2*cx*s2x*sy**2*c2z&
+ !!$ -10.*s2x*c2y*pi*sz**2*ct&
+!!$ +10.*s2x*sy**2*c2z*pi*ct&
+!!$ -2.*s2x*cy**2*pi*c2z*ct&
+!!$ +2.*s2x*c2y*pi*cz**2*ct)
+!!$
+!!$ s(2)=2.*pi**2*(-2.*sx**2*s2y*c2z*st - c2x*s2y*sz**2*st &
+!!$ +8.*sx**3*s2y**2*s2z*ct**2*c2z*cx - 8.*s2x*sy**2*s2z*ct**2*sx**2*c2y*c2z &
+!!$ -4.*s2x*sy**2*s2z*ct**2*c2x*c2y*sz**2 - 2.*s2x*s2y**2*sz**3*ct**2*c2x*cz &
+!!$ +4.*s2x*sy*s2z*ct**2*cy*sx**2*s2y*c2z &
+!!$ +2.*s2x*sy*s2z*ct**2*cy*c2x*s2y*sz**2 - 4.*cx**2*pi*s2y*c2z*ct &
+!!$ +20.*sx**2*s2y*c2z*pi*ct + 10.*c2x*pi*s2y*sz**2*ct - 2.*cx*pi*s2y*cz**2*ct)
+!!$
+!!$ s(3)=-2.*pi**2*(-c2x*sy**2*s2z*st - 2.*sx**2*c2y*s2z*st &
+!!$ +8.*sx**3*s2y*s2z**2*ct**2*c2y*cx - 2.*s2x*sy**3*s2z**2*ct**2*c2x*cy &
+!!$ -4.* s2x*s2y*sz**2*ct**2*c2x*sy**2*c2z - 8.*s2x*s2y*sz**2*ct**2*sx**2*c2y*c2z &
+!!$ +2.*s2x*s2y*sz*ct**2*cz*c2x*sy**2*s2z &
+!!$ +4.*s2x*s2y*sz*ct**2*cz*sx**2*c2y*s2z&
+!!$ +10.*c2x*pi*sy**2*s2z*ct - 4.*cx**2*pi*c2y*s2z*ct&
+!!$ +20.*sx**2*c2y*pi*s2z*ct - 2.*c2x*pi*cy**2*s2z*ct)
+
+
+ !sol analytique stationnaire
+ !---------------------------
+ s(1)=4.*pi**2*(-4.*sx**2*s2y*s2z*c2x*c2y*sz**2 &
+ +4.*sx**2*s2y*s2z*c2x*sy**2*c2z - s2x**2*sy**3*s2z*c2z*cy&
+ +s2x**2*s2y*sz**3*c2y*cz&
+ +2.*sx*s2y*s2z*cx*s2x*c2y*sz**2 - 2.*sx*s2y*s2z*cx*s2x*sy**2*c2z&
+ -5.*nu*s2x*c2y*pi*sz**2 + 5.*nu*s2x*sy**2*c2z*pi - nu*s2x*cy**2*pi*c2z + nu*s2x*c2y*pi*cz**2)
+
+ s(2)=4.*pi**2*(4.*sx**3*s2y**2*s2z*c2z*cx - 4.*s2x*sy**2*s2z*sx**2*c2y*c2z &
+ -2.*s2x*sy**2*s2z*c2x*c2y*sz**2 - s2x*s2y**2*sz**3*c2x*cz &
+ +2.*s2x*sy*s2z*cy*sx**2*s2y*c2z&
+ +s2x*sy*s2z*cy*c2x*s2y*sz**2 - 2.*nu*cx**2*pi*s2y*c2z + 10.*nu*sx**2*s2y*c2z*pi&
+ +5.*nu*c2x*pi*s2y*sz**2 - nu*c2x*pi*s2y*cz**2)
+
+ s(3)=-4.*pi**2*(4.*sx**3*s2y*s2z**2*c2y*cx - s2x*sy**3*s2z**2*c2x*cy&
+ -2.*s2x*s2y*sz**2*c2x*sy**2*c2z - 4.*s2x*s2y*sz**2*sx**2*c2y*c2z&
+ +s2x*s2y*sz*cz*c2x*sy**2*s2z + 2.*s2x*s2y*sz*cz*sx**2*c2y*s2z&
+ +5.*nu*c2x*pi*sy**2*s2z - 2.*nu*cx**2*pi*c2y*s2z + 10.*nu*sx**2*c2y*pi*s2z - nu*c2x*pi*cy**2*s2z)
+
+ !sol analytique stationnaire: sans strech ni diffusion
+ !-------------------------------------------------------
+!!$ s(1)=4.*pi**2*(-2.*sx**2*s2y*s2z*c2x*c2y*sz**2&
+!!$ +2.*sx**2*s2y*s2z*c2x*sy**2*c2z - s2x**2*sy**3*s2z*c2z*cy&
+!!$ +s2x**2*s2y*sz**3*c2y*cz)
+!!$
+!!$ s(2)=4.*pi**2*(4.*sx**3*s2y**2*s2z*c2z*cx - 2.*s2x*sy**2*s2z*sx**2*c2y*c2z &
+!!$ -s2x*sy**2*s2z*c2x*c2y*sz**2 - s2x*s2y**2*sz**3*c2x*cz)
+!!$
+!!$ s(3)=-4.*pi**2*(4.*sx**3*s2y*s2z**2*c2y*cx - s2x*sy**3*s2z**2*c2x*cy&
+!!$ -s2x*s2y*sz**2*c2x*sy**2*c2z - 2.*s2x*s2y*sz**2*sx**2*c2y*c2z)
+
+
+ !sol analytique stationnaire: que diffusion
+ !---------------------------------------------
+!!$ s(1)=4.*pi**2*(-2.*sx**2*s2y*s2z*c2x*c2y*sz**2 &
+!!$ +2.*sx**2*s2y*s2z*c2x*sy**2*c2z - s2x**2*sy**3*s2z*c2z*cy&
+!!$ +s2x**2*s2y*sz**3*c2y*cz - 5.*nu*s2x*c2y*pi*sz**2&
+!!$ + 5.*nu*s2x*sy**2*c2z*pi - nu*s2x*cy**2*pi*c2z + nu*s2x*c2y*pi*cz**2)
+!!$
+!!$
+!!$ s(2)=4.*pi**2*(4.*sx**3*s2y**2*s2z*c2z*cx - 2.*s2x*sy**2*s2z*sx**2*c2y*c2z &
+!!$ -s2x*sy**2*s2z*c2x*c2y*sz**2 - s2x*s2y**2*sz**3*c2x*cz &
+!!$ - 2.*nu*cx**2*pi*s2y*c2z + 10.*nu*sx**2*s2y*c2z*pi&
+!!$ +5.*nu*c2x*pi*s2y*sz**2 - nu*c2x*pi*s2y*cz**2)
+!!$
+!!$ s(3)=-4.*pi**2*(4.*sx**3*s2y*s2z**2*c2y*cx - s2x*sy**3*s2z**2*c2x*cy&
+!!$ -s2x*s2y*sz**2*c2x*sy**2*c2z - 2.*s2x*s2y*sz**2*sx**2*c2y*c2z&
+!!$ +5.*nu*c2x*pi*sy**2*s2z - 2.*nu*cx**2*pi*c2y*s2z + 10.*nu*sx**2*c2y*pi*s2z - nu*c2x*pi*cy**2*s2z)
+
+ !sol analytique stationnaire: que strech
+ !----------------------------------------
+!!$ s(1)=4.*pi**2*(-4.*sx**2*s2y*s2z*c2x*c2y*sz**2 &
+!!$ +4.*sx**2*s2y*s2z*c2x*sy**2*c2z - s2x**2*sy**3*s2z*c2z*cy&
+!!$ +s2x**2*s2y*sz**3*c2y*cz&
+!!$ +2.*sx*s2y*s2z*cx*s2x*c2y*sz**2 - 2.*sx*s2y*s2z*cx*s2x*sy**2*c2z)
+!!$
+!!$ s(2)=4.*pi**2*(4.*sx**3*s2y**2*s2z*c2z*cx - 4.*s2x*sy**2*s2z*sx**2*c2y*c2z &
+!!$ -2.*s2x*sy**2*s2z*c2x*c2y*sz**2 - s2x*s2y**2*sz**3*c2x*cz &
+!!$ +2.*s2x*sy*s2z*cy*sx**2*s2y*c2z&
+!!$ +s2x*sy*s2z*cy*c2x*s2y*sz**2)
+!!$
+!!$ s(3)=-4.*pi**2*(4.*sx**3*s2y*s2z**2*c2y*cx - s2x*sy**3*s2z**2*c2x*cy&
+!!$ -2.*s2x*s2y*sz**2*c2x*sy**2*c2z - 4.*s2x*s2y*sz**2*sx**2*c2y*c2z&
+!!$ +s2x*s2y*sz*cz*c2x*sy**2*s2z + 2.*s2x*s2y*sz*cz*sx**2*c2y*s2z)
+
+
+ end subroutine source_anal
+
+
+
+end module source_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/tab_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/tab_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..49d94467eaeaf86bf2370b2b3b953653d9bab30e
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/tab_mod.f90
@@ -0,0 +1,23 @@
+module tab_mod
+
+ !grille
+ real(kind=8),dimension(:,:,:),pointer :: vxg,vyg,vzg,vxg1,vyg1,vzg1,vxg2,vyg2,vzg2,vxg3,vyg3,vzg3,vxg4,vyg4,vzg4
+ real(kind=8),dimension(:,:,:),pointer :: chi,chi_sphere,lambda
+ real(kind=8),dimension(:,:,:),pointer :: omgx,omgy,omgz,deb1,deb2,deb3
+ real(kind=8),dimension(:),pointer :: xtab,ytab,ztab
+ integer,dimension(:,:,:),pointer :: numpg
+ !particule
+ real(kind=8),dimension(:),pointer :: xp,yp,zp,qp,vx,vy,vz,xp0,xp1,xp2,xp3,yp0,yp1,yp2,yp3,zp0,zp1,zp2,zp3
+ real(kind=8),dimension(:),pointer :: vx0,vx1,vx2,vx3,vx4,vx5,vy0,vy1,vy2,vy3,vy4,vy5,vz0,vz1,vz2,vz3,vz4,vz5
+ real(kind=8),dimension(:),pointer :: omx,omy,omz
+ integer,dimension(:),pointer :: blocg,blocd,Nbloc
+
+
+ real,dimension(:,:,:),pointer :: omgxr,omgyr,omgzr,vxgr,vygr,vzgr
+
+ real(kind=8),dimension(:,:,:),pointer ::stxg,styg,stzg
+ real(kind=8),dimension(:),pointer ::stx,sty,stz
+
+
+
+end module tab_mod
diff --git a/CodesEnVrac/NavierStokes3D-Penalization/src/utile_mod.f90 b/CodesEnVrac/NavierStokes3D-Penalization/src/utile_mod.f90
new file mode 100644
index 0000000000000000000000000000000000000000..acdcffae287d4e8a22cab6b96b471518fe98efa7
--- /dev/null
+++ b/CodesEnVrac/NavierStokes3D-Penalization/src/utile_mod.f90
@@ -0,0 +1,369 @@
+module utile_mod
+ use donnees_mod
+ use tab_mod
+contains
+
+
+ subroutine make_grille
+ implicit none
+ integer :: i,j,k
+
+ do k=1,nz
+ ztab(k)=zd+(k-1)*dz
+ end do
+ do j=1,ny
+ ytab(j)=yb+(j-1)*dy
+ end do
+ do i=1,nx
+ xtab(i)=xg+(i-1)*dx
+ end do
+
+ end subroutine make_grille
+
+
+
+ subroutine make_bloc(esp)
+ use donnees_mod
+ implicit none
+ integer,intent(in) :: esp
+ integer :: fin,ib,i,j,k,l,im,ip,dim1,dim2,dim3
+ logical :: zero
+ real(kind=8) :: pas
+
+ select case(esp)
+ case(1)
+ dim1=nx
+ dim2=ny
+ dim3=nz
+ pas=dx
+ case(2)
+ dim1=ny
+ dim2=nz
+ dim3=nx
+ pas=dy
+ case(3)
+ dim1=nz
+ dim2=nx
+ dim3=ny
+ pas=dz
+ end select
+
+
+ !-----------------------------------------------------------------------------------------
+ !Determine la nature des blocs
+ !Donne un flag correspondant au type de remaillage necessaire (centre,decentre ou modifie)
+ !------------------------------------------------------------------------------------------
+
+ blocg(1:npart)=1
+ blocd(1:npart)=1
+
+ direction1: do l=1,dim3
+
+ direction2: do j=1,dim2
+
+ !peut calculer la longeur -> gain si longeur eleve
+
+ !parcours la grille, bloc par bloc:determine le type des bloc
+ !---------------------------------
+
+ blocg(0)=100
+ blocd(0)=100
+ Nbloc(0)=100
+
+ type_bloc:do i=1,dim1,long_bloc+1
+
+
+ if ( (i+long_bloc)<(dim1-1) ) then
+ fin=i+long_bloc
+ call sub_typeb
+ else
+ !parcours le bloc plus premier point du bloc suivant
+ fin=dim1-1
+ call sub_typeb
+ blocg(pg(dim1,j,l))=blocg(pg(dim1-1,j,l))
+ blocd(pg(dim1,j,l))=blocd(pg(dim1-1,j,l))
+ Nbloc(pg(dim1,j,l))=Nbloc(pg(dim1-1,j,l))
+ end if
+
+ end do type_bloc
+
+
+ !parcours la grille, bloc par bloc:determine si modif de remaillage necessaire a l'intersection des blocs
+ !---------------------------------
+ type_remaill:do i=1,dim1,long_bloc+1
+
+ if (((i+long_bloc)<dim1).and.(i>1+long_bloc)) then
+ fin=i+long_bloc
+ call sub_remb
+ else
+ if (i<=1+long_bloc)then
+ !premier bloc
+ !-------------
+ fin=i+long_bloc
+ call sub_remb
+
+ else
+ !dernier bloc
+ !-------------
+ fin=dim1
+ call sub_remb
+
+ end if
+
+ end if
+
+ end do type_remaill
+ end do direction2
+ end do direction1
+
+ contains
+
+ subroutine sub_typeb
+
+ integer :: ni,N
+ real(kind=8) :: li
+ logical :: pasfait
+
+
+ !parcours une premiere fois le bloc pour savoir si c'est un bloc en 0 ou 1/2
+ !----------------------------------
+ pasfait=.true.
+ zero=.true.
+ do_zero:do ib=i,fin+1 !eviter cas change de bloc quand maille vide
+ if (pg(ib,j,l)/=0) then
+ if (pasfait) then !le N doit etre le meme pour tout le bloc !
+ li=dt/pas*vit(pg(ib,j,l))
+ ni=floor(li+0.5D0)
+ pasfait=.false.
+ end if
+ li=dt/pas*vit(pg(ib,j,l))
+ if ( ((li)<(ni-0.5D0)).or.((li)>(ni+0.5D0)) ) then
+ zero=.false.
+ exit do_zero
+ end if
+ end if
+ end do do_zero
+
+
+ !parcours a nouveau le bloc
+ !-------------------------
+ !affecte le type de bloc a toute les part du bloc
+
+ pasfait=.true.
+ bloc2:do ib=i,fin
+
+ if (pg(ib,j,l)/=0) then
+
+ !calcul de N
+ !------------
+ if (pasfait) then
+ if (zero) then
+ N=floor(dt/pas*vit(pg(ib,j,l))+0.5D0)
+ pasfait=.false.
+ else
+ N=floor(dt/pas*vit(pg(ib,j,l)))
+ pasfait=.false.
+ end if
+ end if
+
+ if (zero) then
+ !bloc pour lambda2 centre
+ blocg(pg(ib,j,l))=0
+ blocd(pg(ib,j,l))=0
+ end if
+
+ !affecte la constante N
+ Nbloc(pg(ib,j,l))=N
+
+ end if
+ end do bloc2
+
+ end subroutine sub_typeb
+
+
+ subroutine sub_remb
+ implicit none
+
+ integer,dimension(-2:2) :: iper
+ integer :: k
+
+
+ !parcours a nvx le bloc
+ !-----------------------
+ !detecte s'il y aura une correction de remaillage a apporter à l'intersection de ces blocs
+
+ bloc3:do ib=i,fin,fin-i
+
+ if (pg(ib,j,l)/=0) then
+
+ !si fin de bloc en 0. :
+ !----------------------
+ do k=-2,2
+ iper(k)=pg(mod(ib+k+dim1-1,dim1)+1,j,l)
+ end do
+
+
+ if ((ib==fin).and.(blocd(pg(ib,j,l))==0).and.((blocg(iper(1))==1) &
+ .or.(blocg(iper(2))==1)).and.((Nbloc(iper(1))==Nbloc(pg(ib,j,l))-1) &
+ .or.(Nbloc(iper(2))==Nbloc(pg(ib,j,l))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j,l))<=Nbloc(pg(ib,j,l)) ) then
+ blocg(iper(1))=2
+ blocd(pg(ib,j,l))=3
+ else
+ blocg(iper(1))=2
+ blocd(pg(ib,j,l))=4
+ blocg(pg(ib,j,l))=5
+ end if
+
+ else
+ blocg(iper(1))=2
+ blocg(iper(2))=5
+
+ if ( dt/pas*vit(pg(ib,j,l))<=Nbloc(pg(ib,j,l)) ) then
+ blocd(pg(ib,j,l))=3
+ else
+ blocd(pg(ib,j,l))=7
+ blocg(pg(ib,j,l))=8
+ end if
+
+ if ( dt/pas*vit(iper(-1))<=Nbloc(pg(ib,j,l)) ) then
+ blocd(iper(-1))=6
+ else
+ blocd(iper(-1))=5
+ end if
+ end if
+
+ end if
+
+
+ !si debut de bloc en 0 : detecte quelle correction il faudra apporter
+ !----------------------
+ if ((ib==i) .and.(blocg(pg(ib,j,l))==0).and.((blocd(iper(-1))==1) &
+ .or.(blocd(iper(-2))==1)).and.((Nbloc(iper(-1))==Nbloc(pg(ib,j,l))-1) &
+ .or. (Nbloc(iper(-2))==Nbloc(pg(ib,j,l))-1) ) ) then
+
+ if (type_b==2) then
+
+ if ( dt/pas*vit(pg(ib,j,l))>Nbloc(pg(ib,j,l)) ) then
+ blocd(iper(-1))=2
+ blocg(pg(ib,j,l))=4
+ else
+ blocd(iper(-1))=2
+ blocg(pg(ib,j,l))=3
+ end if
+
+ else
+
+ blocd(iper(-1))=2
+ blocd(iper(-2))=4
+
+ if ( dt/pas*vit(pg(ib,j,l))>Nbloc(pg(ib,j,l)) ) then
+ blocg(pg(ib,j,l))=4
+ else
+ blocg(pg(ib,j,l))=3
+ end if
+
+ if ( dt/pas*vit(iper(1))>Nbloc(pg(ib,j,l)) ) then
+ blocg(iper(1))=7
+ else
+ blocg(iper(1))=6
+ end if
+
+ end if
+ end if
+
+
+
+ end if
+ end do bloc3
+
+ end subroutine sub_remb
+
+ function pg(a,b,c)
+ implicit none
+ integer,intent(in) :: a,b,c
+ integer :: pg
+
+ select case (esp)
+ case(1)
+ pg=numpg(a,b,c)
+ case(2)
+ pg=numpg(c,a,b)
+ case(3)
+ pg=numpg(b,c,a)
+ end select
+
+ end function pg
+
+ function vit(ind)
+ implicit none
+ integer,intent(in) :: ind
+ real(kind=8) :: vit
+
+ select case (esp)
+ case(1)
+ vit=vx(ind)
+ case(2)
+ vit=vy(ind)
+ case(3)
+ vit=vz(ind)
+ end select
+
+ end function vit
+
+
+ end subroutine make_bloc
+
+
+ subroutine imposer_debit(u,debit,dimx,dimy,dimz,deltax,deltay,deltaz)
+ implicit none
+ real(kind=8),dimension(:,:,:),intent(inout) :: u
+ real(kind=8),intent(in) :: debit,deltax,deltay,deltaz
+ integer,intent(in) :: dimx,dimy,dimz
+ real(kind=8) :: debit0
+ integer :: i,j,k
+
+ !calcul du debit volumique actuel: int_x int_y int_z u dx dy dz
+ !---------------------------------
+ debit0=0.
+
+ do k=1,dimz
+ do j=1,dimy
+ debit0=debit0+u(1,j,k)
+ end do
+ end do
+ debit0=debit0*deltay*deltaz
+
+ !on impose le débit voulu
+ !------------------------
+ do i=1,dimx
+ do k=1,dimz
+ do j=1,dimy
+ u(i,j,k)=u(i,j,k)-debit0/(dimy*dimz*deltay*deltaz)!soustraction du debit actuel
+ u(i,j,k)=u(i,j,k)+debit/(dimy*dimz*deltay*deltaz)!affectation de la valeur du débit désirée
+ end do
+ end do
+ end do
+
+ !ON a ainsi:
+ !------------
+ !
+ !int u(nouveau) dx dy dz = dx dy dz sum u (nouveau)
+ ! = dx dy dz sum u (old) - debit0 + debit = debit
+ !
+ !
+
+
+ end subroutine imposer_debit
+
+
+
+
+
+
+ end module utile_mod
+
+
diff --git a/CodesEnVrac/Remesh/4GB/arrays.h b/CodesEnVrac/Remesh/4GB/arrays.h
new file mode 100644
index 0000000000000000000000000000000000000000..e45762cf0e9a9d94b3fd507687b098eda0fe3c05
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/arrays.h
@@ -0,0 +1,10 @@
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),vx(npg)
+
+
diff --git a/CodesEnVrac/Remesh/4GB/param.h b/CodesEnVrac/Remesh/4GB/param.h
new file mode 100644
index 0000000000000000000000000000000000000000..e6e8a2c9debc539b335a89f3defbbcaef4c4f233
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/param.h
@@ -0,0 +1,3 @@
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,dx1
+ common nx2,ny2,nz2,dx2,nx3
+ common circlim,cfl,nx,dx
\ No newline at end of file
diff --git a/CodesEnVrac/Remesh/4GB/param.i b/CodesEnVrac/Remesh/4GB/param.i
new file mode 100644
index 0000000000000000000000000000000000000000..bb8dbac4ad3cbbe9cb2700c1d6a1d8f80c627cb7
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/param.i
@@ -0,0 +1,3 @@
+ parameter(npm=2100000,npgx=256,npgy=256,npgz=256)
+ parameter(npg=256)
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshx_l2.f b/CodesEnVrac/Remesh/4GB/remeshx_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..51e6cdf6be3e20ca45c683209dee4dfa04170cad
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshx_l2.f
@@ -0,0 +1,96 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ endif
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshx_tag.f b/CodesEnVrac/Remesh/4GB/remeshx_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..1c789564fe4d28ad059d5b78f02f6cf6dd212539
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshx_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshx_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag-1,2
+ i=itag(n)
+c ii=mod(i,nx2)+1
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+c case (c) and (d)
+c
+c if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+xx1*u1-yy1*u2
+ ug(ip3,jj,kk)=ug(ip3,jj,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(ip4,jj,kk)=ug(ip4,jj,kk)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c else
+c case (d)
+c endif
+ else
+c case (c') and (d')
+c
+c if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(ip0,jj,kk)=ug(ip0,jj,kk)+a0*u1
+ ug(ip1,jj,kk)=ug(ip1,jj,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(ip2,jj,kk)=ug(ip2,jj,kk)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+c else
+c case (d')
+c endif
+ endif
+ enddo
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshy_l2.f b/CodesEnVrac/Remesh/4GB/remeshy_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..001f52cf277baf72f32c0312a0975cac33c7aa7c
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshy_l2.f
@@ -0,0 +1,82 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx
+
+ do i=1,nx
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshy_tag.f b/CodesEnVrac/Remesh/4GB/remeshy_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..9330ef9222e1ddfa83a6477ca8b74921cf910573
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshy_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshy_tag(ntag,itag,itype,icfl,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+c case (c) and (d)
+c
+c if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+xx1*u1-yy1*u2
+ ug(jj,ip3,kk)=ug(jj,ip3,kk)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(jj,ip4,kk)=ug(jj,ip4,kk)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c else
+c case (d)
+c endif
+ else
+c case (c') and (d')
+c
+c if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(jj,ip0,kk)=ug(jj,ip0,kk)+a0*u1
+ ug(jj,ip1,kk)=ug(jj,ip1,kk)+(1.-a0)*u1+(1.-b2)*u2
+ ug(jj,ip2,kk)=ug(jj,ip2,kk)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+c else
+c case (d')
+c endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshz_l2.f b/CodesEnVrac/Remesh/4GB/remeshz_l2.f
new file mode 100644
index 0000000000000000000000000000000000000000..301471c39867db2789794ebf5887baec3c9808a6
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshz_l2.f
@@ -0,0 +1,82 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx
+
+ do i=1,nx
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/4GB/remeshz_tag.f b/CodesEnVrac/Remesh/4GB/remeshz_tag.f
new file mode 100644
index 0000000000000000000000000000000000000000..805bf055ccf06e52e0fcf7dbf0232cd9885da372
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/remeshz_tag.f
@@ -0,0 +1,86 @@
+ subroutine remeshz_tag(ntag,itag,itype,icfl,kk,jj)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer itag(*),itype(*),icfl(*)
+
+ dxinv=1./dx2
+ x0=xmin
+
+ do n=1,ntag,2
+ i=itag(n)
+ ii=itag(n+1)
+ x=xp(i)
+ y=xp(ii)
+ u1=up(i)
+ u2=up(ii)
+ if (itype(i).eq.0) then
+c case (c) and (d)
+c
+c if (vx(ii)*cfl-icfl(ii).lt.0) then
+ ip1 = int((x-x0)*dxinv)
+ jp1 = nint((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+ yy0=yy1+1
+ yy2=1-yy1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip3=ip1+2
+ ip4=ip1+3
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ ip3=mod(ip3+nx2,nx2) +1
+ ip4=mod(ip4+nx2,nx2) +1
+ a0=-xx1*xx2/2.
+ a1=xx0*xx2
+ b1=yy0*yy2
+ b2=yy0*yy1/2.
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+a1*u1+(1.+yy1-b1-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+xx1*u1-yy1*u2
+ ug(kk,jj,ip3)=ug(kk,jj,ip3)+(1.-a0-a1-xx1)*u1+b1*u2
+ ug(kk,jj,ip4)=ug(kk,jj,ip4)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+c else
+c case (d)
+c endif
+ else
+c case (c') and (d')
+c
+c if (vx(i)*cfl-icfl(i).lt.0) then
+ ip1 = nint((x-x0)*dxinv)
+ jp1 = int((y-x0)*dxinv)
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ yy1 = (y - float(jp1)*dx2-x0)*dxinv
+ xx2=1-xx1
+ yy0=yy1+1
+ ip0=ip1-1
+ ip2=ip1+1
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+ a0=-0.5*xx1*xx2
+ b2=0.5*yy0*yy1
+ ug(kk,jj,ip0)=ug(kk,jj,ip0)+a0*u1
+ ug(kk,jj,ip1)=ug(kk,jj,ip1)+(1.-a0)*u1+(1.-b2)*u2
+ ug(kk,jj,ip2)=ug(kk,jj,ip2)+b2*u2
+c print*, 'REMESH_TAG ',n,i,ii,ip1,jp1
+
+c else
+c case (d')
+c endif
+ endif
+ enddo
+
+
+ return
+ end
+
+
diff --git a/CodesEnVrac/Remesh/4GB/tag_particles.f b/CodesEnVrac/Remesh/4GB/tag_particles.f
new file mode 100644
index 0000000000000000000000000000000000000000..b2a5d0fff5c07d3d06fdf3353653ee18df555295
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/tag_particles.f
@@ -0,0 +1,181 @@
+ subroutine tag_particles(npart,npart_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ include 'param.i'
+ include 'param.h'
+
+ common/remesh/xp(npg),xp1(npg),up(npg),vx(npg)
+
+ integer icfl(*),itype(*),itype_aux(*),itag(*)
+ dimension xp_aux(*),up_aux(*),vx_aux(*)
+
+ integer ntype(npg),ncfl(npg),npart_bl(npg),i_nbl(npg)
+ dimension amin_lambda(npg)
+
+
+c ntype(nbl) : type de bloc (1=centre ou 0=left) pour choix de la formule
+c remaillage
+c itype(npart) : idem pour les particules de ces blocks
+c ncfl(nbl)=cfl-nint ou cfl-int selon le type
+c icfl(npart) : idem pour particules de cs blocks
+c xp_aux(npart_aux): particles inside the blocks, for plain remeshing
+c itype_aux(npart_aux) : type de block pour ces particules
+c ntag: number of tagged particles, for special remeshing
+c itag(ntag): pointer for tagged particles
+c i_nbl(nbl) indice de la derniere particule du bloc nbl
+
+c cfl=delt/dx
+
+ x0=xmin
+
+
+ m=np_bl+1
+ nblock=nx/(m)
+ dx_bl=float(m)*dx
+ dx_bl_inv=1./dx_bl
+
+c on range les partucles par block
+c et on calcule lambda moyen pour chaque block
+
+ do nbl=1,nblock
+ amin_lambda(nbl)=111.
+ npart_bl(nbl)=0
+ i_nbl(nbl)=0
+ enddo
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(i)*cfl)
+ npart_bl(nbl)=npart_bl(nbl)+1
+ i_nbl(nbl)=i
+ enddo
+
+c on ajoute la particule a droite du bloc (si elle existe) pour calculer
+c le amin_lambda, pour eviter pbms a l'interface entre blocs de meme type
+c (a corriger: pour l'instant je ne regarde pas le dernier bloc avec xp(1)
+
+ do nbl=1,nblock-1
+ if (i_nbl(nbl).ne.0) then
+ ii=i_nbl(nbl)
+ if ((ii.lt.npart).and.(xp(ii+1).lt.xp(ii)+1.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(ii+1)*cfl)
+ endif
+ endif
+ enddo
+
+c le dernier bloc (a la main ..)
+
+ nbl=nblock
+ if (i_nbl(nbl).ne.0) then
+ if ((xp(npart).ge.xmax-1.5*dx).and.(xp(1).lt.xmin+0.5*dx)) then
+ amin_lambda(nbl)=amin1(amin_lambda(nbl),vx(1)*cfl)
+ endif
+ endif
+
+
+c et on en deduit type de block (1=centre vs 0=left) et l'indice du bloc
+
+
+ do nbl=1,nblock
+ if (amin_lambda(nbl).lt.nint(amin_lambda(nbl))) then
+ ntype(nbl)=1
+ ncfl(nbl)=nint(amin_lambda(nbl))
+ else
+ ntype(nbl)=0
+ ncfl(nbl)=int(amin_lambda(nbl))
+ if (amin_lambda(nbl).lt.0) ncfl(nbl)=int(amin_lambda(nbl))-1
+ endif
+
+c print*,'nbl et type',nbl, ntype(nbl),amin_lambda(nbl)
+ enddo
+c
+c on affecte le type et l'indice cfl du bloc sur ses particules
+
+
+ do i=1,npart
+ nbl=1+int((xp(i)-x0+0.00001)*dx_bl_inv)
+ itype(i)=ntype(nbl)
+ icfl(i)=ncfl(nbl)
+c print*,'nbl et type',nbl,i, itype(i),icfl(i)
+ enddo
+
+
+c on tagge les particules entre les blocs successifs non vides qui:
+c sont de type et indice cfl differents
+c (cases b,c,b',c' du papier)
+
+ ntag=0
+ npart_aux=0
+ j=2
+ jc=0
+ do i=2,npart-1
+ j=j+jc
+ if (j.ge.npart) go to 111
+ jj=j+1
+c print*,j,icfl(j),icfl(jj),itype(j),itype(jj)
+ if ((icfl(j).ne.icfl(jj)).and.(itype(j).ne.itype(jj))
+ 1 .and.(xp(jj).le.xp(j)+1.5*dx)) then
+ ntag=ntag+1
+ itag(ntag)=j
+ ntag=ntag+1
+ itag(ntag)=j+1
+c print*,' **** TAGGED ',j,xp(j),itype(j),icfl(j),vx(j)*delt/dx,
+c 1 nint(vx(j)*delt/dx)
+c print*,' **** TAGGED ',jj,xp(jj),itype(jj),icfl(jj),vx(jj)*delt/dx,
+c 1 nint(vx(jj)*delt/dx)
+ jc=2
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(j)
+ up_aux(npart_aux)=up(j)
+ vx_aux(npart_aux)=vx(j)
+ itype_aux(npart_aux)=itype(j)
+c print*,'REGULAR',npart_aux,xp_aux(npart_aux),up_aux(npart_aux)
+c 1 ,vx_aux(j)*delt/dx,icfl(j)
+ jc=1
+ endif
+ enddo
+
+111 continue
+
+c on regarde a part la premiere et la derniere particule
+c (je ne sais pas faire autrement pour l'instant)
+
+ if (npart.ge.1) then
+
+ if ((icfl(1).ne.icfl(npart)).and.(itype(1).ne.itype(npart))
+ 1 .and.(xp(npart).ge.xp(1)+(float(nx)-1.5)*dx)
+ 1 .and.(itag(ntag).ne.npart)) then
+c 1 ) then
+ ntag=ntag+1
+ itag(ntag)=npart
+ ntag=ntag+1
+ itag(ntag)=1
+c print*,' TAGGED ',j,xp(j),icfl(j)
+ else
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(1)
+ up_aux(npart_aux)=up(1)
+ vx_aux(npart_aux)=vx(1)
+ itype_aux(npart_aux)=itype(1)
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ if (npart.gt.1) then
+ npart_aux=npart_aux+1
+ xp_aux(npart_aux)=xp(npart)
+ up_aux(npart_aux)=up(npart)
+ vx_aux(npart_aux)=vx(npart)
+ itype_aux(npart_aux)=itype(npart)
+ endif
+c print*, ' REGULAR ',npart_aux,up_aux(npart_aux),xp_aux(npart_aux)
+ endif
+
+ endif
+
+
+
+c if (ntag.ne.0) print*,'npart,NTAG, NPART_AUX = ',npart,ntag,npart_aux
+
+
+ return
+ end
diff --git a/CodesEnVrac/Remesh/4GB/velox_x.f b/CodesEnVrac/Remesh/4GB/velox_x.f
new file mode 100644
index 0000000000000000000000000000000000000000..19d7d5e9f4bbbe02d926771b69dbb2c7517a14cb
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/velox_x.f
@@ -0,0 +1,106 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_x(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g1(npg)
+
+ do 10 i=1,npart
+ g1(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/4GB/velox_y.f b/CodesEnVrac/Remesh/4GB/velox_y.f
new file mode 100644
index 0000000000000000000000000000000000000000..5249524362c079764754826199ae712f1e1d6291
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/velox_y.f
@@ -0,0 +1,104 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_y(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),gg2(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g2(npg)
+
+ do 10 i=1,npart
+ g2(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + gg2(jp1,ip2,kp1)*a2*b1*c1
+ g2(i)= g2(i) + gg2(jp2,ip1,kp1)*a1*b2*c1
+ g2(i)= g2(i) + gg2(jp2,ip2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + gg2(jp1,ip2,kp2)*a2*b1*c2
+ g2(i)= g2(i) + gg2(jp2,ip1,kp2)*a1*b2*c2
+ g2(i)= g2(i) + gg2(jp2,ip2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/4GB/velox_z.f b/CodesEnVrac/Remesh/4GB/velox_z.f
new file mode 100644
index 0000000000000000000000000000000000000000..1130201e8191781a2bdacb63269a21ff4813d464
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/velox_z.f
@@ -0,0 +1,105 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_z(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g3(npg)
+
+
+ do 10 i=1,npart
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip1)*a1*b1*c1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip2)*a2*b1*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip1)*a1*b2*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip2)*a2*b2*c1
+ g3(i)= g3(i) + gg3(jp1,kp2,ip1)*a1*b1*c2
+ g3(i)= g3(i) + gg3(jp1,kp2,ip2)*a2*b1*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip1)*a1*b2*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip2)*a2*b2*c2
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/4GB/x_advect.f b/CodesEnVrac/Remesh/4GB/x_advect.f
new file mode 100644
index 0000000000000000000000000000000000000000..7414f8c383a79396aa4198f3d70504d0134e7d3c
--- /dev/null
+++ b/CodesEnVrac/Remesh/4GB/x_advect.f
@@ -0,0 +1,107 @@
+ subroutine x_advect(dt,np_bl)
+
+c version pour GB
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+c routine d'advection en x :
+c parcours des lignes horozontales
+c intilisation de particules
+c calcul des vitesses par RK2
+c tag des particules en focntion des varaitions de cfl
+c push and remesh
+
+c cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+c 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+c initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+
+c GB modif pour laversion avec correction:
+c mettre en c les lignes qui suivent
+c et remplacer par call tag_particles
+c modifs simlaires a faire dans y_advect et z_advect
+
+ call velox_x(np,j,k)
+cc do n=1,np
+cc xp_aux(n)=xp0(n)
+cc vx_aux(n)=vx(n)
+c itype(n)=1
+c enddo
+
+ call tag_particles(np,np_aux,ntag,np_bl,
+ 1 icfl,itype,itype_aux,itag,
+ 1 xp_aux,up_aux,vx_aux)
+
+ if (ntag.ne.0) then
+ do n=1,ntag
+ ii=itag(n)
+ xp(ii)=xp0(ii)+dt*vx(ii)
+ if (xp(ii).gt.xmax) xp(ii)=xp(ii)-xmax+xmin
+ enddo
+ endif
+
+222 continue
+c GB: changer dans les lignes qui suivent np en np_aux :
+ do n=1,np_aux
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np_aux,xp_aux,up_aux,itype,jr,kr)
+c
+c GB : remesh des particules tagguees:
+c appeler remeshx_tag et mettre pour les 2 derniers arguments
+c les memes parametres que dans remeshx (remeshy ou remeshz si y_advect
+c ou z_advect)
+ if (ntag.ne.0) call remeshx_tag(ntag,itag,itype,icfl,jr,kr)
+
+c fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/arrays.h b/CodesEnVrac/Remesh/FFTPAR/4GB/arrays.h
new file mode 100755
index 0000000000000000000000000000000000000000..e45762cf0e9a9d94b3fd507687b098eda0fe3c05
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/arrays.h
@@ -0,0 +1,10 @@
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),vx(npg)
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/param.h b/CodesEnVrac/Remesh/FFTPAR/4GB/param.h
new file mode 100755
index 0000000000000000000000000000000000000000..e6e8a2c9debc539b335a89f3defbbcaef4c4f233
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/param.h
@@ -0,0 +1,3 @@
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,dx1
+ common nx2,ny2,nz2,dx2,nx3
+ common circlim,cfl,nx,dx
\ No newline at end of file
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/param.i b/CodesEnVrac/Remesh/FFTPAR/4GB/param.i
new file mode 100755
index 0000000000000000000000000000000000000000..bb8dbac4ad3cbbe9cb2700c1d6a1d8f80c627cb7
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/param.i
@@ -0,0 +1,3 @@
+ parameter(npm=2100000,npgx=256,npgy=256,npgz=256)
+ parameter(npg=256)
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/remeshx_l2.f b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshx_l2.f
new file mode 100755
index 0000000000000000000000000000000000000000..51e6cdf6be3e20ca45c683209dee4dfa04170cad
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshx_l2.f
@@ -0,0 +1,96 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ endif
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/remeshy_l2.f b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshy_l2.f
new file mode 100755
index 0000000000000000000000000000000000000000..001f52cf277baf72f32c0312a0975cac33c7aa7c
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshy_l2.f
@@ -0,0 +1,82 @@
+ subroutine remeshy(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx
+
+ do i=1,nx
+ ug(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,ip0,kk) = ug(jj,ip0,kk) + g1*a0
+ ug(jj,ip1,kk) = ug(jj,ip1,kk) + g1*a1
+ ug(jj,ip2,kk) = ug(jj,ip2,kk) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/remeshz_l2.f b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshz_l2.f
new file mode 100755
index 0000000000000000000000000000000000000000..301471c39867db2789794ebf5887baec3c9808a6
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/remeshz_l2.f
@@ -0,0 +1,82 @@
+ subroutine remeshz(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx
+
+ do i=1,nx
+ ug(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx,nx) +1
+ ip0=mod(ip0+nx,nx) +1
+ ip2=mod(ip2+nx,nx) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(jj,kk,ip0) = ug(jj,kk,ip0) + g1*a0
+ ug(jj,kk,ip1) = ug(jj,kk,ip1) + g1*a1
+ ug(jj,kk,ip2) = ug(jj,kk,ip2) + g1*a2
+
+ endif
+ enddo
+
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/velox_x.f b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_x.f
new file mode 100755
index 0000000000000000000000000000000000000000..19d7d5e9f4bbbe02d926771b69dbb2c7517a14cb
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_x.f
@@ -0,0 +1,106 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_x(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g1(npg)
+
+ do 10 i=1,npart
+ g1(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/velox_y.f b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_y.f
new file mode 100755
index 0000000000000000000000000000000000000000..5249524362c079764754826199ae712f1e1d6291
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_y.f
@@ -0,0 +1,104 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_y(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),gg2(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g2(npg)
+
+ do 10 i=1,npart
+ g2(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp1)*a1*b1*c1
+ g2(i)= g2(i) + gg2(jp1,ip2,kp1)*a2*b1*c1
+ g2(i)= g2(i) + gg2(jp2,ip1,kp1)*a1*b2*c1
+ g2(i)= g2(i) + gg2(jp2,ip2,kp1)*a2*b2*c1
+ g2(i)= g2(i) + gg2(jp1,ip1,kp2)*a1*b1*c2
+ g2(i)= g2(i) + gg2(jp1,ip2,kp2)*a2*b1*c2
+ g2(i)= g2(i) + gg2(jp2,ip1,kp2)*a1*b2*c2
+ g2(i)= g2(i) + gg2(jp2,ip2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/velox_z.f b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_z.f
new file mode 100755
index 0000000000000000000000000000000000000000..1130201e8191781a2bdacb63269a21ff4813d464
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/velox_z.f
@@ -0,0 +1,105 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_z(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),gg3(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g3(npg)
+
+
+ do 10 i=1,npart
+ g3(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip1)*a1*b1*c1
+ g3(i)= g3(i) + gg3(jp1,kp1,ip2)*a2*b1*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip1)*a1*b2*c1
+ g3(i)= g3(i) + gg3(jp2,kp1,ip2)*a2*b2*c1
+ g3(i)= g3(i) + gg3(jp1,kp2,ip1)*a1*b1*c2
+ g3(i)= g3(i) + gg3(jp1,kp2,ip2)*a2*b1*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip1)*a1*b2*c2
+ g3(i)= g3(i) + gg3(jp2,kp2,ip2)*a2*b2*c2
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/x_advect.f b/CodesEnVrac/Remesh/FFTPAR/4GB/x_advect.f
new file mode 100755
index 0000000000000000000000000000000000000000..04ca4196cafa8099726c7fd43ee8c20128891a58
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/x_advect.f
@@ -0,0 +1,80 @@
+ subroutine x_advect(dt,np_bl)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+c routine d'advection en x :
+c parcours des lignes horozontales
+c intilisation de particules
+c calcul des vitesses par RK2
+c tag des particules en focntion des varaitions de cfl
+c push and remesh
+
+c cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+c 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+c initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np,xp_aux,up_aux,itype,jr,kr)
+
+c fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/y_advect.f b/CodesEnVrac/Remesh/FFTPAR/4GB/y_advect.f
new file mode 100755
index 0000000000000000000000000000000000000000..d12899a84b5e98ea6759e5b4d0fcd8910aae8866
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/y_advect.f
@@ -0,0 +1,65 @@
+ subroutine y_advect(dt,np_bl)
+
+ include 'param.i'
+ include 'param.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+ external velox
+
+
+c on balaie le lignes verticales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nx
+c initiliasation particules sur la ligne j
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ do n=1,np
+ xx=xp_aux(n)
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np,xp_aux,up_aux,itype,ir,kr)
+c fin de ligne i :
+
+ endif
+ enddo
+ enddo
+
+ return
+ end
diff --git a/CodesEnVrac/Remesh/FFTPAR/4GB/z_advect.f b/CodesEnVrac/Remesh/FFTPAR/4GB/z_advect.f
new file mode 100755
index 0000000000000000000000000000000000000000..9708766edec7233064309d6484fdb0882d180d34
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/4GB/z_advect.f
@@ -0,0 +1,64 @@
+ subroutine z_advect(dt,np_bl)
+
+ include 'param.i'
+ include 'param.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+ external velox
+
+c on balaie le lignes azimuthales
+
+ do j=1,nx
+ zz=xmin+float(j-1)*dx
+ do i=1,nx
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nx
+c initiliasation particules sur la ligne k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ do n=1,np
+ xx=xp_aux(n)
+ call velox_z(i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo ir=i
+ jr=j
+ call remeshz(np,xp_aux,up_aux,itype,ir,jr)
+c fin de ligne k :
+
+ endif
+ enddo
+ enddo
+
+ return
+ end
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/Makefile b/CodesEnVrac/Remesh/FFTPAR/Makefile
new file mode 100755
index 0000000000000000000000000000000000000000..061fa9d5f9d9d78301f4648deae2c85838b39778
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/Makefile
@@ -0,0 +1,39 @@
+F90 = /opt/openmpi/bin/mpif90
+CODE = fft_2
+FILES = precision.f90 fileio.f90 string.f90 parser.f90 mpi_init.f90 data.f90 random.f90 transforms.f90 initscal.f90 parinit.f90 tg_init.f90 init_plane_jet.f90 init_test_case.f90 solver.f90 forcing.f90 tools.f90 main.f90 postprocesstools.f90 postprocess.f90 postprocess5.f90 postprocessparaview.f90 discretisation2.f90 postprocess6.f90 postprocess7.f90 discretisation3.f90 x_advec.f90 y_advec.f90 z_advec.f90 lesmodel.f90
+#lesmodel.f90 lesmodelsca.f90 lesmodelsca2.f90 lestools.f90 lesmodelsca3.f90 lesmodelsca4.f90 lesmodelsca5.f90 lesmodelsca6.f90 lesmodelsca7.f90 lesmodelsca8.f90 lesmodelsca9.f90 lesmodelsca10.f90
+
+LIB = /opt/fftw/lib
+LIBFFTW = -L$(LIB) -lfftw3
+FFTWINC = -I/opt/fftw/include
+
+BLAS_DIR = /opt/lapack/
+BLAS_LIB = -L$(BLAS_DIR) -lblas
+LAPACK_DIR = /opt/lapack
+LAPACK_LIB = -L$(LAPACK_DIR) -llapack
+
+
+OFILES = $(FILES:.f90=.o)
+MODFILES = $(FILES:.f90=.mod)
+
+FFLAGS = -O3
+# -qzerosize
+
+.SUFFIXES: .o .f90
+
+default:Makefile
+ @make $(OFILES)
+ @make $(CODE)
+
+
+$(CODE):$(OFILES) Makefile
+ $(F90) $(OFILES) $(FFLAGS) -o $(CODE) $(LIBFFTW) $(LAPACK_LIB) $(BLAS_LIB)
+
+
+
+clean:
+ rm -f *.o *.mod
+
+
+.f90.o:
+ $(F90) $(FFTWINC) $(FFLAGS) -c $*.f90
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/arrays.h b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/arrays.h
new file mode 100755
index 0000000000000000000000000000000000000000..e45762cf0e9a9d94b3fd507687b098eda0fe3c05
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/arrays.h
@@ -0,0 +1,10 @@
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & vxg(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),vx(npg)
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.h b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.h
new file mode 100755
index 0000000000000000000000000000000000000000..e6e8a2c9debc539b335a89f3defbbcaef4c4f233
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.h
@@ -0,0 +1,3 @@
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,dx1
+ common nx2,ny2,nz2,dx2,nx3
+ common circlim,cfl,nx,dx
\ No newline at end of file
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.i b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.i
new file mode 100755
index 0000000000000000000000000000000000000000..bb8dbac4ad3cbbe9cb2700c1d6a1d8f80c627cb7
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/param.i
@@ -0,0 +1,3 @@
+ parameter(npm=2100000,npgx=256,npgy=256,npgz=256)
+ parameter(npg=256)
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/remeshx_l2.f b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/remeshx_l2.f
new file mode 100755
index 0000000000000000000000000000000000000000..51e6cdf6be3e20ca45c683209dee4dfa04170cad
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/remeshx_l2.f
@@ -0,0 +1,96 @@
+ subroutine remeshx(np1,xp1,up1,itype,jj,kk)
+
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ dimension xp1(*),up1(*),itype(*)
+
+
+
+c remaillage des particules fluides
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ ug(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up1(n)
+ x = xp1(n)
+
+ if (itype(n).eq.0) then
+
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+c print*, ' IPO ..',n,xp1(n),ip0,ip1,ip2
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c left-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+c
+c center-Lambda2:
+c
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ ug(ip0,jj,kk) = ug(ip0,jj,kk) + g1*a0
+ ug(ip1,jj,kk) = ug(ip1,jj,kk) + g1*a1
+ ug(ip2,jj,kk) = ug(ip2,jj,kk) + g1*a2
+
+ endif
+ enddo
+
+ go to 222
+ do k=3,nx2-2
+ do j=1,nx2
+ do i=1,nx2
+ if (ug(i,j,k).gt.1.2) then
+ print*,'BOUM', i,j,k,ug(i,j,k)
+ goto 222
+ endif
+ enddo
+ enddo
+ enddo
+
+222 continue
+ RETURN
+ END
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/velox_x.f b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/velox_x.f
new file mode 100755
index 0000000000000000000000000000000000000000..19d7d5e9f4bbbe02d926771b69dbb2c7517a14cb
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/velox_x.f
@@ -0,0 +1,106 @@
+C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ SUBROUTINE velox_x(npart,j,k)
+
+C
+C Interpolation routine with M'4
+C
+c geometry=unit box, periodic in x and y
+c last ponits in z direction assume extension by continuity
+c that is gg(i,j,0)=gg(i,j,1) gg(i,j,m+1)=gg(i,j,m)
+
+
+c----------------------------------------------------------------
+
+ include 'param.i'
+ include 'param.h'
+
+
+ COMMON/GRID/ omg1(npgx,npgy,npgz),
+ & omg2(npgx,npgy,npgz),omg3(npgx,npgy,npgz),
+ & gg1(npgx,npgy,npgz),vyg(npgx,npgy,npgz),vzg(npgx,npgy,npgz),
+ & psi1(npgx,npgy,npgz),psi2(npgx,npgy,npgz),psi3(npgx,npgy,npgz),
+ & strg1(npgx,npgy,npgz),strg2(npgx,npgy,npgz),
+ & strg3(npgx,npgy,npgz),ug(npg,npg,npg)
+
+ common/remesh/xp0(npg),xp(npg),up(npg),g1(npg)
+
+ do 10 i=1,npart
+ g1(i)=0.
+10 continue
+
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+
+c--------------------------------------------------------------------
+c- PART II : Determination of the circulation of each particle
+c--------------------------------------------------------------------
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2=1-yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2=1-zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+
+ DO 20 i = 1,npart
+
+ x = XP(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+C get the circulations from the nine neighboring cells
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+C
+C on repositionne les points de grille par periodicite
+C entre 0 et m-1, puis on numerote de 1 a m
+C
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+C
+C The M'4 scheme
+C
+ a1 = xx2
+ a2 = xx1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp1)*a1*b1*c1
+ g1(i)= g1(i) + gg1(ip2,jp1,kp1)*a2*b1*c1
+ g1(i)= g1(i) + gg1(ip1,jp2,kp1)*a1*b2*c1
+ g1(i)= g1(i) + gg1(ip2,jp2,kp1)*a2*b2*c1
+ g1(i)= g1(i) + gg1(ip1,jp1,kp2)*a1*b1*c2
+ g1(i)= g1(i) + gg1(ip2,jp1,kp2)*a2*b1*c2
+ g1(i)= g1(i) + gg1(ip1,jp2,kp2)*a1*b2*c2
+ g1(i)= g1(i) + gg1(ip2,jp2,kp2)*a2*b2*c2
+
+
+20 CONTINUE
+
+
+
+ RETURN
+ END
diff --git a/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/x_advect.f b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/x_advect.f
new file mode 100755
index 0000000000000000000000000000000000000000..04ca4196cafa8099726c7fd43ee8c20128891a58
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/SRC_COTTET/x_advect.f
@@ -0,0 +1,80 @@
+ subroutine x_advect(dt,np_bl)
+
+ include 'param.i'
+ include 'param.h'
+ include 'arrays.h'
+
+ integer icfl(npg),itype(npg),itype_aux(npg),itag(npg)
+ dimension xp_aux(npg),up_aux(npg),vx_aux(npg)
+
+
+c routine d'advection en x :
+c parcours des lignes horozontales
+c intilisation de particules
+c calcul des vitesses par RK2
+c tag des particules en focntion des varaitions de cfl
+c push and remesh
+
+c cfl=dt/dx utilisee pour calucls de blocs /corrections
+ cfl=dt/dx
+
+ npart=0
+ ntag_total=0
+
+
+c 1) on balaie le tableau ug par lignes horizontales
+
+ do k=1,nx
+ zz=xmin+float(k-1)*dx
+ do j=1,nx
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nx
+c initiliasation particules sur la ligne j,k
+ if (abs(ug(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=ug(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=ug(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ endif
+ enddo
+c tag, push and remesh sur la ligne
+ if (np.ne.0) then
+
+c evaluation des vitesse pour RK2
+
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_x(np,j,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+
+222 continue
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ jr=j
+ kr=k
+ call remeshx(np,xp_aux,up_aux,itype,jr,kr)
+
+c fin de ligne j,k:
+ npart=npart+np
+ ntag_total=ntag_total+ntag
+ endif
+ enddo
+ enddo
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+ return
+ end
diff --git a/CodesEnVrac/Remesh/FFTPAR/TAGS b/CodesEnVrac/Remesh/FFTPAR/TAGS
new file mode 100644
index 0000000000000000000000000000000000000000..5d11231d90f8aceb753a51f369fcddb837cba0fc
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/TAGS
@@ -0,0 +1,242 @@
+
+4GB/arrays.h,40
+ & strg3(npgx,npgy,npgz),ug(6,292
+
+4GB/param.h,504
+ common xmin,1,0
+ common xmin,xmax,1,0
+ common xmin,xmax,ymin,1,0
+ common xmin,xmax,ymin,ymax,1,0
+ common xmin,xmax,ymin,ymax,zmin,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,1,0
+ common nx2,2,58
+ common nx2,ny2,2,58
+ common nx2,ny2,nz2,2,58
+ common nx2,ny2,nz2,dx2,2,58
+
+4GB/remeshx_l2.f,32
+ subroutine remeshx(1,0
+
+4GB/remeshy_l2.f,32
+ subroutine remeshy(1,0
+
+4GB/remeshz_l2.f,32
+ subroutine remeshz(1,0
+
+4GB/velox_x.f,27
+ SUBROUTINE velox_x(2,68
+
+4GB/velox_y.f,27
+ SUBROUTINE velox_y(2,68
+
+4GB/velox_z.f,27
+ SUBROUTINE velox_z(2,68
+
+4GB/x_advect.f,26
+ subroutine x_advect(1,0
+
+4GB/y_advect.f,26
+ subroutine y_advect(1,0
+
+4GB/z_advect.f,26
+ subroutine z_advect(1,0
+
+data.f90,189
+subroutine data_init37,816
+subroutine data_write130,2848
+subroutine tab_write(205,5283
+subroutine tab_write_ne(264,6725
+subroutine data_read327,8255
+subroutine data_filter_sc389,9709
+
+discretisation2.f90,32
+subroutine discretisation2(1,0
+
+discretisation3.f90,32
+subroutine discretisation3(1,0
+
+fileio.f90,67
+ integer function iopen(16,283
+ integer function iclose(44,918
+
+forcing.f90,98
+subroutine forcing_init15,132
+subroutine force_compute93,1985
+function force_spectrum(162,4142
+
+init_plane_jet.f90,30
+subroutine init_plane_jet1,0
+
+init_test_case.f90,30
+subroutine init_test_case1,0
+
+initscal.f90,27
+subroutine init_scalar1,0
+
+lesmodel.f90,28
+subroutine dynsmagmodel1,0
+
+main.f90,25
+subroutine main_init1,0
+
+mpi_init.f90,95
+subroutine mpi_initialize32,544
+subroutine parallel_max(159,2557
+subroutine barrier175,2822
+
+parinit.f90,24
+subroutine hit_init1,0
+
+parser.f90,634
+ subroutine parser_pack(30,838
+ subroutine parser_spread47,1362
+ subroutine parser_newentry(66,1873
+ subroutine parser_fieldfortag(86,2422
+ subroutine parser_is_defined(106,2946
+ subroutine parser_readlogical(119,3276
+ subroutine parser_readint(142,3938
+ subroutine parser_readfloat(165,4586
+ subroutine parser_readchar(188,5246
+ subroutine parser_getsize(211,5930
+ subroutine parser_readintarray(242,6964
+ subroutine parser_readfloatarray(262,7516
+ subroutine parser_readfloatarray2D(282,8139
+ subroutine parser_readchararray(302,8712
+subroutine parser_init324,9327
+subroutine parser_parsefile(339,9613
+
+postprocess.f90,27
+subroutine postprocess1,0
+
+postprocess5.f90,28
+subroutine postprocess51,0
+
+postprocess6.f90,28
+subroutine postprocess61,0
+
+postprocess7.f90,28
+subroutine postprocess71,0
+
+postprocessparaview.f90,134
+subroutine dump_data(1,0
+subroutine dump_geometry66,1777
+subroutine dump_geometry_scalar169,4594
+subroutine dump_data_sc(275,7511
+
+postprocesstools.f90,1112
+subroutine cc_pdf(1,0
+subroutine c_pdf_sca(62,1572
+subroutine c_pdf_sca_fix(115,2951
+subroutine c_pdf(156,4146
+subroutine cn_pdf(209,5499
+subroutine cp_pdf(267,6937
+subroutine var_skew_fla(325,8374
+subroutine corre(345,8811
+subroutine moyen_reg1(365,9299
+subroutine moyen_reg2(393,10002
+subroutine moyensc(421,10706
+subroutine moyen(442,11151
+subroutine moyen_ysc(463,11578
+subroutine moyen_y(486,12053
+subroutine mean_cond_2(509,12504
+subroutine mean_cond(590,14960
+subroutine physboxfilter(646,16674
+subroutine specboxfiltersc(704,18225
+subroutine specboxfilter(755,20360
+subroutine speccutboxfilter2sc(805,22360
+subroutine speccutboxfilter2(866,24754
+subroutine speccutboxfilter(927,27007
+subroutine speccutboxfiltersc(988,29256
+subroutine specgaussfiltersc(1051,31648
+subroutine specgaussfilter(1081,32529
+subroutine curl(1111,33342
+subroutine gradntsc(1154,34803
+subroutine gradientsc(1191,35988
+subroutine gradient(1228,37128
+subroutine cutgradient(1265,38154
+subroutine speccutfilter(1310,39464
+subroutine speccutfiltersc(1345,40327
+subroutine turbulent_region(1379,41257
+
+random.f90,32
+subroutine random_init100,4137
+
+solver.f90,193
+subroutine solver_init58,1521
+subroutine solver_step242,6089
+subroutine non_linear404,10573
+subroutine get_timestep881,23079
+subroutine dealias923,23926
+subroutine fourier_write963,24870
+
+SRC_COTTET/arrays.h,40
+ & strg3(npgx,npgy,npgz),ug(6,292
+
+SRC_COTTET/param.h,504
+ common xmin,1,0
+ common xmin,xmax,1,0
+ common xmin,xmax,ymin,1,0
+ common xmin,xmax,ymin,ymax,1,0
+ common xmin,xmax,ymin,ymax,zmin,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,1,0
+ common xmin,xmax,ymin,ymax,zmin,zmax,nx1,ny1,nz1,nt,1,0
+ common nx2,2,58
+ common nx2,ny2,2,58
+ common nx2,ny2,nz2,2,58
+ common nx2,ny2,nz2,dx2,2,58
+
+SRC_COTTET/remeshx_l2.f,32
+ subroutine remeshx(1,0
+
+SRC_COTTET/velox_x.f,27
+ SUBROUTINE velox_x(2,68
+
+SRC_COTTET/x_advect.f,26
+ subroutine x_advect(1,0
+
+tg_init.f90,23
+subroutine tg_init1,0
+
+tools.f90,187
+subroutine dns_stats1,0
+subroutine u_compute231,5617
+subroutine uz_compute253,6018
+subroutine get_spectrum(279,6541
+subroutine get_dns_numbers(416,9373
+subroutine tg_stats582,13668
+
+transforms.f90,254
+subroutine forward_transform(15,391
+subroutine backward_transform(76,1692
+subroutine transpose_forward(134,2954
+subroutine transpose_backward(172,3696
+subroutine transform_init219,4446
+subroutine ftran_wrap(241,4801
+subroutine btran_wrap(283,5510
+
+x_advec.f90,116
+subroutine x_advec_init25,560
+subroutine x_advec68,1124
+subroutine velox_x(133,2549
+subroutine remeshx(213,3996
+
+y_advec.f90,80
+subroutine y_advec1,0
+subroutine velox_y(58,1319
+subroutine remeshy(138,2766
+
+z_advec.f90,80
+subroutine z_advec1,0
+subroutine velox_z(58,1319
+subroutine remeshz(138,2766
+
+string.f90,0
+
+precision.f90,0
diff --git a/CodesEnVrac/Remesh/FFTPAR/data.f90 b/CodesEnVrac/Remesh/FFTPAR/data.f90
new file mode 100755
index 0000000000000000000000000000000000000000..c73bb9768784964d092216b963f5d633f7c696bf
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/data.f90
@@ -0,0 +1,605 @@
+module data
+ use parallel
+ use precision
+ use parser
+ use fileio
+ use string
+ implicit none
+
+
+ integer :: nvar
+
+ real(WP) :: L
+ real(WP) :: Ut, le, ld, epsilon, mu,diff
+ character(len=str_short) :: spectrum
+ character(len=str_medium) :: spfilename,spfilename2
+
+ integer :: file_counter,file_fourier
+
+ real(WP), dimension(:,:,:,:), pointer :: data_store
+ real(WP), dimension(:,:,:), pointer :: data_storesc
+ real(WP), dimension(:,:,:), pointer :: U
+ real(WP), dimension(:,:,:), pointer :: V
+ real(WP), dimension(:,:,:), pointer :: W
+ real(WP), dimension(:,:,:), pointer :: SC
+
+ type MPI_IO_VAR
+ real(WP), dimension(:,:,:), pointer :: var
+ integer :: view
+ end type MPI_IO_VAR
+
+ type(MPI_IO_VAR), dimension(:), pointer :: MPI_IO_DATA
+
+ integer, dimension(4) :: dims_w
+
+end module data
+
+subroutine data_init
+
+ use data
+
+ implicit none
+
+ integer :: gsizes(4),lsizes(4),var,start(4),ierr,nv_fourier
+ integer :: gsizessc(3),lsizessc(3),startsc(3)
+ real(WP) :: sch
+
+! call parser_read('Number of points',nx)
+! call parser_read('Number of points for scalar',nxsc)
+ print*,'nx,nxsc',nx,nxsc
+ call parser_read('Length of domain', L)
+ call parser_read('Spectrum form',spectrum)
+ call parser_read('Viscosity',mu,1e-02_WP)
+ call parser_read('Schmidt number',sch,0.7_WP)
+ diff = mu/sch
+
+ ny = nx
+ nz = nx
+ nvar = 3
+ nv_fourier = 3
+ nysc = nxsc
+ nzsc = nxsc
+
+ allocate(data_store(ns1,ns2,ns3,nvar))
+ allocate(data_storesc(ns1sc,ns2sc,ns3sc))
+
+ data_store = 0.0_WP
+ data_storesc = 0.0_WP
+ U => data_store(:,:,:,1); ! names(1) = 'U'
+ V => data_store(:,:,:,2); ! names(2) = 'V'
+ W => data_store(:,:,:,3); ! names(3) = 'W'
+ SC => data_storesc(:,:,:); ! names(4) = 'P'
+
+
+ dims_w(1) = nx
+ dims_w(2) = ny
+ dims_w(3) = nz
+ dims_w(4) = 3
+
+ allocate(MPI_IO_DATA(dims_w(4)+1))
+
+ do var = 1,dims_w(4)
+ MPI_IO_DATA(var)%var => data_store(:,:,:,var)
+ enddo
+ MPI_IO_DATA(4)%var => data_storesc(:,:,:)
+
+ gsizes(1) = nx
+ gsizes(2) = ny
+ gsizes(3) = nz
+ gsizes(4) = dims_w(4)
+
+ lsizes(1) = ns1
+ lsizes(2) = ns2
+ lsizes(3) = ns3
+ lsizes(4) = 1
+
+ start(1) = nxs-1
+ start(2) = nys-1
+ start(3) = nzs-1
+
+
+ do var = 1, dims_w(4)
+ start(4) = var -1
+ call MPI_TYPE_CREATE_SUBARRAY(4,gsizes,lsizes,start,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,MPI_IO_DATA(var)%view,ierr)
+ call MPI_TYPE_COMMIT(MPI_IO_DATA(var)%view,ierr)
+ end do
+
+ gsizessc(1) = nxsc
+ gsizessc(2) = nysc
+ gsizessc(3) = nzsc
+
+ lsizessc(1) = ns1sc
+ lsizessc(2) = ns2sc
+ lsizessc(3) = ns3sc
+
+ startsc(1) = nxssc-1
+ startsc(2) = nyssc-1
+ startsc(3) = nzssc-1
+
+
+ call MPI_TYPE_CREATE_SUBARRAY(3,gsizessc,lsizessc,startsc,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,MPI_IO_DATA(4)%view,ierr)
+ call MPI_TYPE_COMMIT(MPI_IO_DATA(4)%view,ierr)
+
+
+ file_counter = 0
+ file_fourier = 0
+end subroutine data_init
+
+subroutine data_write
+
+ use parallel
+ use data
+ implicit none
+
+
+ integer :: ifile, ierr, var, data_size
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(KIND=MPI_OFFSET_KIND) :: disp
+ character(len=str_medium) :: filename,buffer
+
+ logical :: file_is_there
+
+ file_counter = file_counter+1
+
+ call parser_read('Data file to write',filename)
+ write(buffer,'(I3)') file_counter
+ spfilename = trim(adjustl(filename))//'_sp_'//trim(adjustl(buffer))
+ spfilename2 = trim(adjustl(filename))//'_sz_'//trim(adjustl(buffer))
+ call get_dns_numbers(0)
+
+ filename = trim(filename)
+ write(buffer,'(I3)') file_counter
+ filename = trim(adjustl(filename))//'-'//trim(adjustl(buffer))
+
+
+ inquire(file=filename, exist=file_is_there)
+ if (file_is_there) call MPI_FILE_DELETE(filename,MPI_INFO_NULL,ierr)
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_WRONLY+MPI_MODE_CREATE, &
+ MPI_INFO_NULL,ifile,ierr)
+
+ ! Write header
+ if (rank.eq.0) then
+ ! Write dimensions
+ call MPI_FILE_WRITE(ifile,dims_w,4,MPI_INTEGER,status,ierr)
+ end if
+!!$ print*,dims_w
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Computed values before writing ',MPI_IO_DATA(2)%var(1:5,1,3)
+!!$ print *,' data values from datastore ', data_store(nxs:nxs+5,nys,nzs,2)
+!!$ endif
+
+ disp = 4*4
+ data_size = ns1*ns2*ns3
+ do var = 1,dims_w(4)
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,MPI_IO_DATA(var)%view,&
+ &"native",MPI_INFO_NULL,ierr)
+ call MPI_FILE_WRITE_ALL(ifile,MPI_IO_DATA(var)%var,data_size,&
+ &MPI_REAL_WP,status,ierr)
+ enddo
+
+ disp = 4_MPI_OFFSET_KIND*4 + 8_MPI_OFFSET_KIND*ns1*ns1*ns1*3
+ data_size = ns1sc*ns2sc*ns3sc
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,MPI_IO_DATA(4)%view,&
+ &"native",MPI_INFO_NULL,ierr)
+ call MPI_FILE_WRITE_ALL(ifile,MPI_IO_DATA(4)%var,data_size,&
+ &MPI_REAL_WP,status,ierr)
+! if(rank.eq.0) print*,' size data write 1 : ',4*4 + 8*ns1*ns1*ns1*3 + 8*nproc*ns1sc*ns2sc*ns3sc
+! if(rank.eq.0) print*,' size data write 2 : ',ns1,nproc,ns1sc,ns2sc,ns3sc
+! if(rank.eq.0) print*,' size data write 3 : ',disp
+
+!!$ if (rank.eq.0) then
+!!$ print *,' test writing ',MPI_IO_DATA(1)%var(1,1,1)
+!!$ print *,' test writing ',MPI_IO_DATA(2)%var(1,1,1)
+!!$ print *,' test writing ',MPI_IO_DATA(3)%var(1,1,1)
+!!$ print *,' test writing ',MPI_IO_DATA(4)%var(1,1,1)
+!!$ endif
+
+ call MPI_FILE_CLOSE(ifile,ierr)
+
+end subroutine data_write
+
+
+subroutine tab_write(tab,filename)
+
+ use parallel
+ use data
+ implicit none
+
+ real(WP) :: tab(ns1,ns2,ns3)
+
+ integer :: ifile, ierr, var, data_size, view1
+ integer :: gsize1(4),lsize1(4),start1(4)
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(KIND=MPI_OFFSET_KIND) :: disp
+ character*13 :: filename,buffer
+
+ logical :: file_is_there
+
+ inquire(file=filename, exist=file_is_there)
+ if (file_is_there) call MPI_FILE_DELETE(filename,MPI_INFO_NULL,ierr)
+
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_WRONLY+MPI_MODE_CREATE, &
+ MPI_INFO_NULL,ifile,ierr)
+ disp = 4*4
+ data_size = ns1*ns2*ns3
+
+ gsize1(1) = nx
+ gsize1(2) = ny
+ gsize1(3) = nz
+ gsize1(4) = 1
+
+ lsize1(1) = ns1
+ lsize1(2) = ns2
+ lsize1(3) = ns3
+ lsize1(4) = 1
+
+ start1(1) = nxs-1
+ start1(2) = nys-1
+ start1(3) = nzs-1
+ start1(4) = 0
+
+ call MPI_TYPE_CREATE_SUBARRAY(4,gsize1,lsize1,start1,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,view1,ierr)
+ call MPI_TYPE_COMMIT(view1,ierr)
+
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,view1,&
+ &"native",MPI_INFO_NULL,ierr)
+
+ call MPI_FILE_WRITE_ALL(ifile,tab,data_size,&
+ &MPI_REAL_WP,status,ierr)
+
+
+ !if(rank.eq.0) print*,'1',' 1',' 1',tab(1,1,1)
+ !if(rank.eq.0) print*,'1',' 1',' 32',tab(1,1,32)
+ !if(rank.eq.7) print*,'1',' 1',' 256',tab(1,1,32)
+ !if(rank.eq.7) print*,'1',' 128',' 256',tab(1,128,32)
+
+ call MPI_FILE_CLOSE(ifile,ierr)
+
+end subroutine tab_write
+
+subroutine tab_write_ne(tab,filename,ns1ne,ns2ne,ns3ne)
+
+ use parallel
+ use data
+ implicit none
+
+
+ integer :: ns1ne,ns2ne,ns3ne
+ real(WP) :: tab(ns1ne,ns2ne,ns3ne)
+
+ integer :: ifile, ierr, var, data_size, view1
+ integer :: gsize1(4),lsize1(4),start1(4)
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(KIND=MPI_OFFSET_KIND) :: disp
+ character*13 :: filename,buffer
+
+ logical :: file_is_there
+
+ inquire(file=filename, exist=file_is_there)
+ if (file_is_there) call MPI_FILE_DELETE(filename,MPI_INFO_NULL,ierr)
+
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_WRONLY+MPI_MODE_CREATE, &
+ MPI_INFO_NULL,ifile,ierr)
+ disp = 4*4
+ data_size = ns1ne*ns2ne*ns3ne
+
+ gsize1(1) = ns1ne
+ gsize1(2) = ns1ne
+ gsize1(3) = ns1ne
+ gsize1(4) = 1
+
+ lsize1(1) = ns1ne
+ lsize1(2) = ns2ne
+ lsize1(3) = ns3ne
+ lsize1(4) = 1
+
+ start1(1) = 0
+ start1(2) = 0
+ start1(3) = (rank)*ns3ne
+ start1(4) = 0
+
+ call MPI_TYPE_CREATE_SUBARRAY(4,gsize1,lsize1,start1,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,view1,ierr)
+ call MPI_TYPE_COMMIT(view1,ierr)
+
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,view1,&
+ &"native",MPI_INFO_NULL,ierr)
+
+ call MPI_FILE_WRITE_ALL(ifile,tab,data_size,&
+ &MPI_REAL_WP,status,ierr)
+
+
+ !if(rank.eq.0) print*,'1',' 1',' 1',tab(1,1,1)
+ !if(rank.eq.0) print*,'1',' 1',' 32',tab(1,1,32)
+ !if(rank.eq.7) print*,'1',' 1',' 256',tab(1,1,32)
+ !if(rank.eq.7) print*,'1',' 128',' 256',tab(1,128,32)
+
+ call MPI_FILE_CLOSE(ifile,ierr)
+
+end subroutine tab_write_ne
+
+
+
+subroutine data_read
+
+ use parallel
+ use data
+ implicit none
+
+
+ integer :: ifile, ierr, var, data_size
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(KIND=MPI_OFFSET_KIND) :: disp
+ character(len=str_medium) :: filename,buffer
+
+ logical :: file_is_there
+
+
+
+ call parser_read('Data file to read',filename)
+ filename = trim(filename)
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,filename,MPI_MODE_RDONLY, &
+ MPI_INFO_NULL,ifile,ierr)
+
+ ! Write header
+ if (rank.eq.0) then
+ ! Write dimensions
+ call MPI_FILE_READ(ifile,dims_w,4,MPI_INTEGER,status,ierr)
+ end if
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Computed values before writing ',MPI_IO_DATA(2)%var(1:5,1,3)
+!!$ print *,' data values from datastore ', data_store(nxs:nxs+5,nys,nzs,2)
+!!$ endif
+
+
+
+ disp = 4*4
+ data_size = ns1*ns2*ns3
+ do var = 1,dims_w(4)
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,MPI_IO_DATA(var)%view,&
+ &"native",MPI_INFO_NULL,ierr)
+ call MPI_FILE_READ_ALL(ifile,MPI_IO_DATA(var)%var,data_size,&
+ &MPI_REAL_WP,status,ierr)
+ enddo
+
+
+ disp = 4_MPI_OFFSET_KIND*4 + 8_MPI_OFFSET_KIND*ns1*ns1*ns1*3
+ data_size = ns1sc*ns2sc*ns3sc
+
+
+ call MPI_FILE_SET_VIEW(ifile,disp,MPI_REAL_WP,MPI_IO_DATA(4)%view,&
+ &"native",MPI_INFO_NULL,ierr)
+
+
+ call MPI_FILE_READ_ALL(ifile,MPI_IO_DATA(4)%var,data_size,&
+ &MPI_REAL_WP,status,ierr)
+
+
+ call MPI_FILE_CLOSE(ifile,ierr)
+
+
+end subroutine data_read
+
+
+subroutine data_filter_sc
+
+ use parallel
+ use data
+
+ implicit none
+
+ integer :: nx2,ny2,nz2
+ integer :: ns1f,ns2f,ns3f
+ integer :: i,j,k,jl
+ integer :: nk2, fnys2,fnye2,nkk
+
+ real(WP) :: dk2, pi,kk,grms,buf, xx
+
+ real(WP), dimension(:,:,:), pointer :: tab
+ real(WP), dimension(:,:,:), pointer :: SCF, UF, VF, WF
+
+ integer :: gsizes(4),lsizes(4),var,start(4),ierr,nv_fourier,ifilter
+ integer :: gsizessc(3),lsizessc(3),startsc(3)
+
+ call parser_read('final number of points',nx2)
+ call parser_read('filter',ifilter,0)
+
+ ny2 = nx2
+ nz2 = nx2
+
+ ns1f = nx2
+ ns2f = nx2
+ ns3f = nx2/nproc
+
+ ! -- filtering operation >> UF, VF, WF, SCF
+ allocate(SCF(ns1f,ns2f,ns3f))
+ allocate(UF(ns1,ns2,ns3))
+ allocate(VF(ns1,ns2,ns3))
+ allocate(WF(ns1,ns2,ns3))
+
+ !-- -- -- compute the fourier coefficient
+ pi = acos(-1.0_WP)
+ dk2 = 2.0_WP*pi/L
+
+ nk2 = nx2/2+1
+ nkk = nxsc/2+1
+
+ !-- -- -- SPECTRAL SPACE : SC_nx -> SCF_nx2
+
+ allocate(tab(ns1sc,ns2sc,ns3sc))
+ tab=SC**2
+ buf=0.
+ do k=1,ns3sc
+ do j=1,ns2sc
+ do i=1,ns1sc
+ buf=buf+tab(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,grms,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ if (rank.eq.0) print*," U rms =",grms/(2.0*ns1sc**3)
+ deallocate(tab)
+
+if (nk2.le.nkk) then
+
+! do i = 1, ns1sc
+! xx = (i-1)*L/(ns1sc-1)
+! SC(i,:,:) = sin(xx)
+! print*,xx,SC(i,1,1)
+! end do
+
+ call discretisation3(SC,SCF,ns1sc,ns2sc,ns3sc,ns1f,ns2f,ns3f)
+
+ UF = U
+ VF = V
+ WF = W
+ call barrier
+ if (rank.eq.0) print*,'SC done'
+
+! do i = 1, ns1f
+! xx = (i-1)*L/(ns1f-1)
+! print*,xx,SCF(i,2,2)
+! end do
+
+else
+
+ call discretisation2(SC,SCF,ns1sc,ns2sc,ns3sc,ns1f,ns2f,ns3f)
+ UF = U
+ VF = V
+ WF = W
+
+end if
+
+ ns1sc = ns1f
+ ns2sc = ns2f
+ ns3sc = ns3f
+
+ allocate(tab(ns1sc,ns2sc,ns3sc))
+ tab=SCF**2
+ buf=0.
+ do k=1,ns3sc
+ do j=1,ns2sc
+ do i=1,ns1sc
+ buf=buf+tab(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,grms,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ print*," U rms =",grms/(2.0*ns1sc**3.),ns1sc,ns1f
+ deallocate(tab)
+
+!! do i = 1, ns1sc
+!! do j = 1, ns2sc
+!! do k = 1, ns3sc
+!! SCF(i,j,k) = 100*i + 10*j + k
+!! print*,'SCF',i,j,k,SCF(i,j,k)
+!! end do
+!! end do
+!! end do
+
+
+ ! -- end filtering operation
+
+ deallocate(data_storesc)
+ deallocate(data_store)
+
+ nxsc = nx2
+ nysc = ny2
+ nzsc = nz2
+
+ nxssc = 1
+ nxesc = nxsc
+ nyssc = 1
+ nyesc = nysc
+ nzssc = 1 +(rank)*ns3sc
+ nzesc = (rank+1)*ns3sc
+
+ allocate(data_store(ns1,ns2,ns3,nvar))
+ allocate(data_storesc(ns1sc,ns2sc,ns3sc))
+
+ data_store = 0.0_WP
+ data_storesc = 0.0_WP
+ U => data_store(:,:,:,1); ! names(1) = 'U'
+ V => data_store(:,:,:,2); ! names(2) = 'V'
+ W => data_store(:,:,:,3); ! names(3) = 'W'
+ SC => data_storesc(:,:,:); ! names(4) = 'P'
+
+
+ dims_w(1) = nx
+ dims_w(2) = ny
+ dims_w(3) = nz
+ dims_w(4) = 3
+
+ deallocate(MPI_IO_DATA)
+ allocate(MPI_IO_DATA(dims_w(4)+1))
+
+ do var = 1,dims_w(4)
+ MPI_IO_DATA(var)%var => data_store(:,:,:,var)
+ enddo
+ MPI_IO_DATA(4)%var => data_storesc(:,:,:)
+
+ gsizes(1) = nx
+ gsizes(2) = ny
+ gsizes(3) = nz
+ gsizes(4) = dims_w(4)
+
+ lsizes(1) = ns1
+ lsizes(2) = ns2
+ lsizes(3) = ns3
+ lsizes(4) = 1
+
+ start(1) = nxs-1
+ start(2) = nys-1
+ start(3) = nzs-1
+
+
+ do var = 1, dims_w(4)
+ start(4) = var -1
+ call MPI_TYPE_CREATE_SUBARRAY(4,gsizes,lsizes,start,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,MPI_IO_DATA(var)%view,ierr)
+ call MPI_TYPE_COMMIT(MPI_IO_DATA(var)%view,ierr)
+ end do
+
+ gsizessc(1) = nxsc
+ gsizessc(2) = nysc
+ gsizessc(3) = nzsc
+
+ lsizessc(1) = ns1sc
+ lsizessc(2) = ns2sc
+ lsizessc(3) = ns3sc
+
+ startsc(1) = nxssc-1
+ startsc(2) = nyssc-1
+ startsc(3) = nzssc-1
+
+
+ call MPI_TYPE_CREATE_SUBARRAY(3,gsizessc,lsizessc,startsc,&
+ &MPI_ORDER_FORTRAN,MPI_REAL_WP,MPI_IO_DATA(4)%view,ierr)
+ call MPI_TYPE_COMMIT(MPI_IO_DATA(4)%view,ierr)
+
+ SC = SCF
+ U = UF
+ V = VF
+ W = WF
+ deallocate(SCF)
+ deallocate(UF)
+ deallocate(VF)
+ deallocate(WF)
+!! do i = 1, ns1sc
+!! do j = 1, ns2sc
+!! do k = 1, ns3sc
+!! print*,'SC',i,j,k,SC(i,j,k)
+!! end do
+!! end do
+!! end do
+
+ file_counter = 0
+end subroutine data_filter_sc
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/discretisation2.f90 b/CodesEnVrac/Remesh/FFTPAR/discretisation2.f90
new file mode 100755
index 0000000000000000000000000000000000000000..80e03addb5c3e8fd7b36426da55e10550bea0aff
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/discretisation2.f90
@@ -0,0 +1,157 @@
+subroutine discretisation2(U1,U2,ns1old,ns2old,ns3old,ns1new,ns2new,ns3new)
+
+ use solver
+ use parallel
+! use data
+
+ implicit none
+
+ integer :: ns1old,ns2old,ns3old,ns1new,ns2new,ns3new
+ integer :: fns1old,fns2old,fns3old,fns1new,fns2new,fns3new
+ real(WP) :: U1(ns1old,ns2old,ns3old)
+ real(WP) :: U2(ns1new,ns2new,ns3new)
+ complex(WP), dimension(:,:,:), allocatable :: U1k, U2k, U1kscloc, U1ksc, tabbuf
+ integer :: sizemess, tag, ierr, status(MPI_STATUS_SIZE), i, j, k
+ integer :: yeloc, ysloc, yelocsc, yslocsc, rank2send1, rank2send2, fs1, fe1, fs2, fe2, fnysrank, fnyerank, cptrank
+
+ fns1old = ns1old/2+1
+ fns2old = ns1old/nproc
+ fns3old = ns1old
+
+ fns1new = ns1new/2+1
+ fns2new = ns1new/nproc
+ fns3new = ns1new
+
+ allocate(U1k(fns1old,fns2old,fns3old))
+ call ftran_wrap(U1,U1k,ns1old,ns2old,ns3old,fns1old,fns2old,fns3old)
+ U1k = U1k/real(ns1old**3.0,WP)
+
+ allocate(U1kscloc(fns1old,fns2new,fns3old))
+ U1kscloc = 0.
+
+ ! Communication
+ do cptrank = 0, nproc-1
+
+ fnysrank = 1 + cptrank*fns2old
+ fnyerank = (1+cptrank)*fns2old
+
+ ! Envoi
+ if (fnyerank.le.ns1old/2+1) then ! envoi j de 1 Ã <nk
+ rank2send1 = floor(real(fnyerank-1)/real(fns2new))
+ rank2send2 = floor(real(fnysrank-1)/real(fns2new))
+ fs1 = max(fnysrank,1+rank2send1*fns2new)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2new)
+ fs2 = max(fnysrank,1+rank2send2*fns2new)
+ fe2 = min(fnyerank,(1+rank2send2)*fns2new)
+ else if(fnysrank.gt.ns1old/2+1) then ! envoi j de >nk à nx
+ rank2send1 = floor(real(fnyerank+ns1new-ns1old-1)/real(fns2new))
+ rank2send2 = floor(real(fnysrank+ns1new-ns1old-1)/real(fns2new))
+ fs1 = max(fnysrank,1+rank2send1*fns2new+ns1old-ns1new)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2new+ns1old-ns1new)
+ fs2 = max(fnysrank,1+rank2send2*fns2new+ns1old-ns1new)
+ fe2 = min(fnyerank,(1+rank2send2)*fns2new+ns1old-ns1new)
+ else if(fnysrank.le.ns1old/2+1.and.fnyerank.gt.ns1old/2+1) then
+ rank2send1 = floor(real(fnyerank+ns1new-ns1old-1)/real(fns2new))
+ rank2send2 = floor(real(fnysrank-1)/real(fns2new))
+ fs1 = max(ns1old/2+2,1+rank2send1*fns2new+ns1old-ns1new)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2new+ns1old-ns1new)
+ fs2 = max(fnysrank,1+rank2send2*fns2new)
+ fe2 = min(ns1old/2+1,(1+rank2send2)*fns2new)
+ end if
+ if (rank.eq.cptrank) then
+ ysloc = fs1 - rank * fns2old
+ yeloc = fe1 - rank * fns2old
+ if(cptrank.ne.rank2send1) then
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tabbuf(:,:,:) = U1k(:,ysloc:yeloc,:)
+ tag = fs1+1000*fe1+1000000*1
+ call MPI_SEND(tabbuf,sizemess,MPI_COMPLEX_WP,rank2send1,tag,MPI_COMM_WORLD,ierr)
+ deallocate(tabbuf)
+ else
+ if (fnye.le.ns1old/2+1) then
+ yslocsc = fs1 - rank * fns2new
+ yelocsc = fe1 - rank * fns2new
+ else
+ yslocsc = fs1 - rank * fns2new - ns1old + ns1new
+ yelocsc = fe1 - rank * fns2new - ns1old + ns1new
+ end if
+ U1kscloc(:,yslocsc:yelocsc,:) = U1k(:,ysloc:yeloc,:)
+ end if
+ if (rank2send1.ne.rank2send2) then
+ ysloc = fs2 - rank * fns2old
+ yeloc = fe2 - rank * fns2old
+ if (cptrank.ne.rank2send2) then
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tabbuf(:,:,:) = U1k(:,ysloc:yeloc,:)
+ tag = fs2+1000*fe2+1000000*1
+ call MPI_SEND(tabbuf,sizemess,MPI_COMPLEX_WP,rank2send2,tag,MPI_COMM_WORLD,ierr)
+ deallocate(tabbuf)
+ else
+ if (fnye.le.ns1old/2+1) then
+ yslocsc = fs2 - rank * fns2new
+ yelocsc = fe2 - rank * fns2new
+ else
+ yslocsc = fs2 - rank * fns2new - ns1old + ns1new
+ yelocsc = fe2 - rank * fns2new - ns1old + ns1new
+ end if
+ U1kscloc(:,yslocsc:yelocsc,:) = U1k(:,ysloc:yeloc,:)
+ end if
+ end if
+ else if (rank.eq.rank2send1.and.rank2send1.ne.cptrank) then
+ fnysrank = 1 + rank*fns2new
+ fnyerank = (1+rank)*fns2new
+ if (fnyerank.gt.(ns1new-ns1old+ns1old/2+1)) then
+ ysloc = fs1 - rank * fns2new + ns1new - ns1old
+ yeloc = fe1 - rank * fns2new + ns1new - ns1old
+ else
+ ysloc = fs1 - rank * fns2new
+ yeloc = fe1 - rank * fns2new
+ end if
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs1+1000*fe1+1000000*1
+ call MPI_RECV(tabbuf,sizemess,MPI_COMPLEX_WP,cptrank,tag,MPI_COMM_WORLD,status,ierr)
+ U1kscloc(:,ysloc:yeloc,:) = tabbuf(:,:,:)
+ deallocate(tabbuf)
+ else if (rank.eq.rank2send2.and.rank2send2.ne.cptrank.and.rank2send2.ne.rank2send1) then
+ fnysrank = 1 + rank*fns2new
+ fnyerank = (1+rank)*fns2new
+ if (fnyerank.gt.(ns1new-ns1old+ns1old/2+1)) then
+ ysloc = fs2 - rank * fns2new + ns1new - ns1old
+ yeloc = fe2 - rank * fns2new + ns1new - ns1old
+ else
+ ysloc = fs2 - rank * fns2new
+ yeloc = fe2 - rank * fns2new
+ end if
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs2+1000*fe2+1000000*1
+ call MPI_RECV(tabbuf,sizemess,MPI_COMPLEX_WP,cptrank,tag,MPI_COMM_WORLD,status,ierr)
+ U1kscloc(:,ysloc:yeloc,:) = tabbuf(:,:,:)
+ deallocate(tabbuf)
+ end if
+ end do
+ call MPI_BARRIER(MPI_COMM_WORLD,ierr)
+
+ allocate(U1ksc(fns1new,fns2new,fns3new))
+ U1ksc = 0.
+
+ do i = 1 , ns1old/2 + 1
+ do k = 1 , ns1old/2 + 1
+ U1ksc(i,:,k) = U1kscloc(i,:,k)
+ end do
+ do k = ns1new-ns1old/2+2 , ns1new
+ U1ksc(i,:,k) = U1kscloc(i,:,ns1old-ns1new+k)
+ end do
+ end do
+ deallocate(U1kscloc)
+
+ call btran_wrap(U1ksc,U2,ns1new,ns2new,ns3new,fns1new,fns2new,fns3new)
+
+ deallocate(U1ksc)
+
+end subroutine discretisation2
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/discretisation3.f90 b/CodesEnVrac/Remesh/FFTPAR/discretisation3.f90
new file mode 100755
index 0000000000000000000000000000000000000000..930dbc3b3cd4b584c2bba17242c455e91e468f20
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/discretisation3.f90
@@ -0,0 +1,222 @@
+subroutine discretisation3(U1,U2,ns1old,ns2old,ns3old,ns1new,ns2new,ns3new)
+
+ ! fns1new < fns1old
+
+ use solver
+ use parallel
+
+ implicit none
+
+ integer :: ns1old,ns2old,ns3old,ns1new,ns2new,ns3new
+ integer :: fns1old,fns2old,fns3old,fns1new,fns2new,fns3new,fs,fe,fsold,feold,yminnew,ymaxnew,yminold,ymaxold
+ real(WP) :: U1(ns1old,ns2old,ns3old)
+ real(WP) :: U2(ns1new,ns2new,ns3new)
+ complex(WP), dimension(:,:,:), allocatable :: U1k, U2k, U1kscloc, U1ksc, tabbuf
+ integer :: sizemess, tag, ierr, status(MPI_STATUS_SIZE), i, j, k, itest
+ integer :: yeloc, ysloc, yelocsc, yslocsc, rank2send1, rank2send2, fs1, fe1, fs2, fe2, fnysrank, fnyerank, cptrank, rank2send
+
+! print*,ns1old,ns2old,ns3old,ns1new,ns2new,ns3new
+
+ fns1old = ns1old/2+1
+ fns2old = ns1old/nproc
+ fns3old = ns1old
+
+ fns1new = ns1new/2+1
+ fns2new = ns1new/nproc
+ fns3new = ns1new
+
+ allocate(U1k(fns1old,fns2old,fns3old))
+ call ftran_wrap(U1,U1k,ns1old,ns2old,ns3old,fns1old,fns2old,fns3old)
+ U1k = U1k/real(ns1old**3.0,WP)
+
+ allocate(U1ksc(fns1new,fns2new,fns3new))
+ U1ksc = 0.
+
+ if (nproc.ne.1) then
+
+ allocate(U1kscloc(fns1old,fns2new,fns3old))
+ U1kscloc = 0.
+
+ ! Communication
+ do cptrank = 0, nproc-1
+
+ fnysrank = 1 + cptrank*fns2new
+ fnyerank = (1+cptrank)*fns2new
+
+ ! Envoi
+ if (fnyerank.le.ns1new/2+1) then ! envoi j de 1 Ã <nk
+
+ rank2send1 = floor(real(fnyerank-1)/real(fns2old))
+ rank2send2 = floor(real(fnysrank-1)/real(fns2old))
+ fs1 = max(fnysrank,1+rank2send1*fns2old)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2old)
+ fs2 = max(fnysrank,1+rank2send2*fns2old)
+ fe2 = min(fnyerank,(1+rank2send2)*fns2old)
+
+ else if(fnysrank.gt.ns1new/2+1) then ! envoi j de >nk à nx
+
+ rank2send1 = floor(real(fnyerank+ns1old-ns1new-1)/real(fns2old))
+ rank2send2 = floor(real(fnysrank+ns1old-ns1new-1)/real(fns2old))
+ fs1 = max(fnysrank,1+rank2send1*fns2old+ns1new-ns1old)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2old+ns1new-ns1old)
+ fs2 = max(fnysrank,1+rank2send2*fns2old+ns1new-ns1old)
+ fe2 = min(fnyerank,(1+rank2send2)*fns2old+ns1new-ns1old)
+
+ else if(fnysrank.le.ns1new/2+1.and.fnyerank.gt.ns1new/2+1) then
+
+ rank2send1 = floor(real(fnyerank+ns1old-ns1new-1)/real(fns2old))
+ rank2send2 = floor(real(fnysrank-1)/real(fns2old))
+ fs1 = max(ns1new/2+2,1+rank2send1*fns2old+ns1new-ns1old)
+ fe1 = min(fnyerank,(1+rank2send1)*fns2old+ns1new-ns1old)
+ fs2 = max(fnysrank,1+rank2send2*fns2old)
+ fe2 = min(ns1new/2+1,(1+rank2send2)*fns2old)
+
+ end if
+
+ ! ENVOIE
+ if (rank.eq.rank2send1.and.rank2send1.ne.cptrank) then
+
+ fnysrank = 1 + rank*fns2old
+ fnyerank = (1+rank)*fns2old
+
+ if (fnyerank.gt.(ns1old-ns1new+ns1new/2+1)) then
+ ysloc = fs1 - rank * fns2old + ns1old - ns1new
+ yeloc = fe1 - rank * fns2old + ns1old - ns1new
+ else
+ ysloc = fs1 - rank * fns2old
+ yeloc = fe1 - rank * fns2old
+ end if
+
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs1+1000*fe1+1000000*1
+ tabbuf(:,:,:) = U1k(:,ysloc:yeloc,:)
+ call MPI_SEND(tabbuf,sizemess,MPI_COMPLEX_WP,cptrank,tag,MPI_COMM_WORLD,ierr)
+ deallocate(tabbuf)
+
+ else if (rank.eq.rank2send2.and.rank2send2.ne.cptrank.and.rank2send2.ne.rank2send1) then
+
+ fnysrank = 1 + rank*fns2old
+ fnyerank = (1+rank)*fns2old
+
+ if (fnyerank.gt.(ns1old-ns1new+ns1new/2+1)) then
+ ysloc = fs2 - rank * fns2old + ns1old - ns1new
+ yeloc = fe2 - rank * fns2old + ns1old - ns1new
+ else
+ ysloc = fs2 - rank * fns2old
+ yeloc = fe2 - rank * fns2old
+ end if
+
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs2+1000*fe2+1000000*1
+ tabbuf(:,:,:) = U1k(:,ysloc:yeloc,:)
+ call MPI_SEND(tabbuf,sizemess,MPI_COMPLEX_WP,cptrank,tag,MPI_COMM_WORLD,ierr)
+ deallocate(tabbuf)
+
+ ! RECEPTION
+ else if (rank.eq.cptrank) then
+
+ ysloc = fs1 - rank * fns2new
+ yeloc = fe1 - rank * fns2new
+
+ if(cptrank.ne.rank2send1) then
+
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs1+1000*fe1+1000000*1
+ call MPI_RECV(tabbuf,sizemess,MPI_COMPLEX_WP,rank2send1,tag,MPI_COMM_WORLD,status,ierr)
+ U1kscloc(:,ysloc:yeloc,:) = tabbuf(:,:,:)
+ deallocate(tabbuf)
+
+ else
+
+ if (fnyerank.le.ns1new/2+1) then
+ yslocsc = fs1 - rank * fns2old
+ yelocsc = fe1 - rank * fns2old
+ else
+ yslocsc = fs1 - rank * fns2old - ns1new + ns1old
+ yelocsc = fe1 - rank * fns2old - ns1new + ns1old
+ end if
+
+ U1kscloc(:,ysloc:yeloc,:) = U1k(:,yslocsc:yelocsc,:)
+
+ end if
+
+ if (rank2send1.ne.rank2send2) then
+
+ ysloc = fs2 - rank * fns2new
+ yeloc = fe2 - rank * fns2new
+
+ if (cptrank.ne.rank2send2) then
+
+ sizemess = fns1old*fns3old*(yeloc-ysloc+1)
+ allocate(tabbuf(fns1old,yeloc-ysloc+1,fns3old))
+ tag = fs2+1000*fe2+1000000*1
+ call MPI_RECV(tabbuf,sizemess,MPI_COMPLEX_WP,rank2send2,tag,MPI_COMM_WORLD,status,ierr)
+ U1kscloc(:,ysloc:yeloc,:) = tabbuf(:,:,:)
+ deallocate(tabbuf)
+
+ else
+
+ if (fnyerank.le.ns1new/2+1) then
+ yslocsc = fs2 - rank * fns2old
+ yelocsc = fe2 - rank * fns2old
+ else
+ yslocsc = fs2 - rank * fns2old - ns1new + ns1old
+ yelocsc = fe2 - rank * fns2old - ns1new + ns1old
+ end if
+
+ U1kscloc(:,ysloc:yeloc,:) = U1k(:,yslocsc:yelocsc,:)
+
+ end if
+
+ end if
+
+ end if
+
+ end do
+ call MPI_BARRIER(MPI_COMM_WORLD,ierr)
+
+
+ do i = 1 , ns1new/2 + 1
+ do k = 1 , ns1new/2 + 1
+ U1ksc(i,:,k) = U1kscloc(i,:,k)
+ end do
+ do k = ns1new, ns1new-ns1new/2+2, -1
+ U1ksc(i,:,k) = U1kscloc(i,:,ns1old-ns1new+k)
+ end do
+ end do
+ deallocate(U1kscloc)
+
+ else
+
+ do i = 1 , ns1new/2 + 1
+ do j = 1, ns1new/2 + 1
+ do k = 1 , ns1new/2 + 1
+ U1ksc(i,j,k) = U1k(i,j,k)
+ end do
+ do k = ns1new, ns1new-ns1new/2+2, -1
+ U1ksc(i,j,k) = U1k(i,j,ns1old-ns1new+k)
+ end do
+ end do
+ do j = ns1new, ns1new-ns1new/2+2, -1
+ do k = 1 , ns1new/2 + 1
+ U1ksc(i,j,k) = U1k(i,ns1old-ns1new+j,k)
+ end do
+ do k = ns1new, ns1new-ns1new/2+2, -1
+ U1ksc(i,j,k) = U1k(i,ns1old-ns1new+j,ns1old-ns1new+k)
+ end do
+ end do
+ end do
+
+ end if
+
+ call btran_wrap(U1ksc,U2,ns1new,ns2new,ns3new,fns1new,fns2new,fns3new)
+
+ deallocate(U1ksc)
+ deallocate(U1k)
+
+end subroutine discretisation3
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/fft_2 b/CodesEnVrac/Remesh/FFTPAR/fft_2
new file mode 100755
index 0000000000000000000000000000000000000000..912b2b8c033a0e58bb8b50565fb9b273c2309952
Binary files /dev/null and b/CodesEnVrac/Remesh/FFTPAR/fft_2 differ
diff --git a/CodesEnVrac/Remesh/FFTPAR/fftpar.tar b/CodesEnVrac/Remesh/FFTPAR/fftpar.tar
new file mode 100755
index 0000000000000000000000000000000000000000..9d6e494af11d8cb794d0778a2370a955638965e4
Binary files /dev/null and b/CodesEnVrac/Remesh/FFTPAR/fftpar.tar differ
diff --git a/CodesEnVrac/Remesh/FFTPAR/fileio.f90 b/CodesEnVrac/Remesh/FFTPAR/fileio.f90
new file mode 100755
index 0000000000000000000000000000000000000000..4e695fca3c4c3ddf4ff1e0841e934cd2f549ab53
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/fileio.f90
@@ -0,0 +1,59 @@
+module fileio
+ use precision
+ implicit none
+
+ ! File index
+ integer :: fileindex
+ integer, dimension(128) :: iunits
+
+contains
+
+ ! ====================== !
+ ! File index management: !
+ ! - open a file !
+ ! - add it to the list !
+ ! ====================== !
+ integer function iopen()
+ implicit none
+
+ integer, save :: icall = 1
+ integer :: i
+
+ if (icall .eq. 1) then
+ fileindex = 1
+ icall = 0
+ end if
+ iunits(fileindex) = 0
+ do i=1,fileindex
+ if (iunits(i) .eq. 0) exit
+ end do
+ if (i .eq. fileindex) then
+ fileindex = fileindex + 1
+ if (fileindex .ge. 128) stop "iopen: maximum units number exceeded"
+ end if
+ iunits(i) = 1
+ iopen = i + 10
+ return
+ end function iopen
+
+ ! ======================= !
+ ! File index management: !
+ ! - close a file !
+ ! - remove it from list !
+ ! ======================= !
+ integer function iclose(iu)
+ implicit none
+
+ integer :: iu
+
+ iu = iu - 10
+ if (iu .gt. 0 .and. iu .lt. fileindex) then
+ iunits(iu) = 0
+ iclose = iu + 10
+ else
+ iclose = -1
+ end if
+ return
+ end function iclose
+
+end module fileio
diff --git a/CodesEnVrac/Remesh/FFTPAR/forcing.f90 b/CodesEnVrac/Remesh/FFTPAR/forcing.f90
new file mode 100755
index 0000000000000000000000000000000000000000..a6f4dad8226d46741351c37952174200d26fc0d2
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/forcing.f90
@@ -0,0 +1,173 @@
+module forcing
+
+ use solver
+ use parallel
+
+ implicit none
+
+ real(WP) :: kf,ka,kb,c
+ real(WP) :: A
+
+
+end module forcing
+
+
+subroutine forcing_init
+
+ use forcing
+ use parser
+
+ implicit none
+
+ integer :: i,j,k
+
+ real(WP) :: kk
+ real(WP) :: force_sum,force_spectrum
+ real(WP) :: P
+ real(WP) :: keta
+ real(WP) :: eta
+ real(WP) :: pi
+ real(WP) :: Rlm,tke
+ real(WP) :: Pf
+ real(WP) :: B,nnodes
+ real(WP), dimension(:), allocatable :: s,stotal
+ integer :: nsize
+ integer :: ierr,ik
+
+
+ pi = acos(-1.0_WP)
+
+ call parser_read('Kmax eta', keta)
+ call parser_read('Number of points',nsize)
+ call parser_read('R Lambda',Rlm)
+ eta = (2.0_WP*keta)/real(nsize,WP)
+ P = mu_solver**3.0_WP/eta**4.0_WP
+
+ kf = (2.0_WP*pi)/((3.0_WP/20.0_WP*Rlm*Rlm)**0.75_WP*eta)
+! kf = (2.0_WP*pi)/((3.0_WP/20.0_WP*Rlm*Rlm)**0.75_WP*eta)-1.
+
+ call parser_read('Power factor',Pf,1.0_WP)
+ kf = kf/Pf
+
+ if (rank.eq.0) print *,' Forcing wavenumber ', kf
+ c = 0.5_WP
+ ka = max(1e-10_WP,kf-2._WP) ! max(1e-10_WP,kf-0.5_WP)
+ kb = kf+1._WP
+
+ force_sum = 0.0_WP
+ nnodes = 0.0_WP
+
+ allocate(s(ns1+1),stotal(ns1+1))
+ s = 0.0_WP
+ stotal = 0.0_WP
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+ ik = 1+idint(kk + 0.5_WP)
+ if (kk.ge.ka.and.kk.le.kb) then
+ force_sum = force_sum + force_spectrum(kk,kf,c)/(2.0_WP*pi*kk**2.0_WP)
+ s(ik) = s(ik) + force_spectrum(kk,kf,c)/(2.0_WP*pi*kk**2.0_WP)
+ nnodes = nnodes + 1.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+
+ call MPI_ALLREDUCE(force_sum,A,1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(nnodes,B,1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(s,stotal,ns1+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+
+ A = P/A
+
+ if (rank.eq.0) print *,' Pre-multiplier for forcing term + nnodes', A,B
+
+
+end subroutine forcing_init
+
+
+subroutine force_compute
+
+ use forcing
+
+ implicit none
+
+ integer :: i,j,k
+
+ real(WP) :: rand,pi,kk,force_spectrum
+ real(WP) :: phi,psi,theta1,theta2
+
+ real(WP) :: e1x,e1y,e1z
+ real(WP) :: e2x,e2y,e2z
+ real(WP) :: kk2,ga,gb
+ complex(WP) :: xi1,xi2,af,bf
+ real(WP) :: rxi1,ixi1,rxi2,ixi2
+ real(WP) :: num,den,f
+
+
+
+ pi = acos(-1.0_WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+
+ kk = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+ kk2 = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP)
+ if (kk2.gt.1e-10_WP.and.kk.gt.1e-10_WP) then
+ if (kk.ge.ka.and.kk.le.kb) then
+ call random_number(rand)
+ phi = pi*rand
+ call random_number(rand)
+ psi = 2.0_WP*pi*rand
+
+ e1x = ky(j)/kk2
+ e1y = -kx(i)/kk2
+ e1z = 0.0_WP
+ e2x = kx(i)*kz(k)/(kk*kk2)
+ e2y = ky(j)*kz(k)/(kk*kk2)
+ e2z = -(kk2)/kk
+ xi1 = Uk(i,j,k)*e1x + Vk(i,j,k)*e1y + Wk(i,j,k)*e1z
+ xi2 = Uk(i,j,k)*e2x + Vk(i,j,k)*e2y + Wk(i,j,k)*e2z
+ rxi1 = real(0.5_WP*(xi1 + conjg(xi1)),WP)
+ rxi2 = real(0.5_WP*(xi2 + conjg(xi2)),WP)
+ ixi1 = real(0.5_WP*(-ii)*(xi1 - conjg(xi1)),WP)
+ ixi2 = real(0.5_WP*(-ii)*(xi2 - conjg(xi2)),WP)
+ ga = sin(2.0_WP*phi)
+ gb = cos(2.0_WP*phi)
+ num = ga*rxi1 + gb*(sin(psi)*ixi2 + cos(psi)*rxi2)
+ den = -ga*ixi1 + gb*(sin(psi)*rxi2 - cos(psi)*ixi2)
+ theta1 = atan(num/den)
+ theta2 = psi + theta1
+ f = A/dt*force_spectrum(kk,kf,c)/(2.0_WP*pi*kk**2.0_WP)
+ af = f**0.5_WP*exp(ii*theta1)*ga
+ bf = f**0.5_WP*exp(ii*theta2)*gb
+ nlx(i,j,k) = nlx(i,j,k) + (af*e1x+bf*e2x)
+ nly(i,j,k) = nly(i,j,k) + (af*e1y+bf*e2y)
+ nlz(i,j,k) = nlz(i,j,k) + (bf*e2z)
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+
+end subroutine force_compute
+
+function force_spectrum(kk,kf,c)
+
+ use precision
+ implicit none
+
+ real(WP) :: force_spectrum
+ real(WP) :: kk,kf,c
+
+
+ force_spectrum = exp(-(kk-kf)**2.0_WP/c)
+
+end function force_spectrum
diff --git a/CodesEnVrac/Remesh/FFTPAR/init_plane_jet.f90 b/CodesEnVrac/Remesh/FFTPAR/init_plane_jet.f90
new file mode 100755
index 0000000000000000000000000000000000000000..ed065a134e8b3558ad8ba3d4d2b39ded0a690265
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/init_plane_jet.f90
@@ -0,0 +1,53 @@
+subroutine init_plane_jet
+
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(:,:,:), pointer :: Ub, Vb, Wb
+ real(WP) :: dx, yy, epsil, Htheta, U1, U2, ubm, vbm, wbm
+ integer :: j
+
+ call hit_init
+
+ allocate(Ub(ns1,ns2,ns3))
+ allocate(Vb(ns1,ns2,ns3))
+ allocate(Wb(ns1,ns2,ns3))
+ Ub = U
+ Vb = V
+ Wb = W
+
+ U = 0.0
+ V = 0.0
+ W = 0.0
+
+ dx = L/(real(nx))
+
+ call parser_read('H/theta',Htheta)
+ call parser_read('Jet velocity',U1)
+ call parser_read('Co-flow velocity',U2)
+ call parser_read('noise level',epsil)
+
+ do j = 1,ns2
+ yy = real(j)*dx - L/2.0
+ U(:,j,:) = (U1+U2)/2.0 + (U1-U2)/2.0 * tanh( 0.25 * Htheta * (1 - 2*abs(yy) ) )
+ SC(:,j,:) = 1.0/2.0 + 1.0/2.0 * tanh( 0.25 * Htheta * (1 - 2*abs(yy) ) )
+ if (abs(yy).gt.0.7.or.abs(yy).lt.0.3) then
+ Ub(:,j,:) = 0.
+ Vb(:,j,:) = 0.
+ Wb(:,j,:) = 0.
+ end if
+ if( rank.eq.0) print*,yy,Ub(1,j,1)
+ end do
+ ubm = maxval(abs(Ub))
+ vbm = maxval(abs(Vb))
+ wbm = maxval(abs(Wb))
+ Ub = Ub/ubm
+ Vb = Vb/vbm
+ Wb = Wb/wbm
+ U = U + epsil*Ub
+ V = V + epsil*Vb
+ W = W + epsil*Wb
+
+end subroutine init_plane_jet
diff --git a/CodesEnVrac/Remesh/FFTPAR/init_test_case.f90 b/CodesEnVrac/Remesh/FFTPAR/init_test_case.f90
new file mode 100755
index 0000000000000000000000000000000000000000..afe628edfb347b5fb67c4c19e54f6f264b5d8e96
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/init_test_case.f90
@@ -0,0 +1,39 @@
+subroutine init_test_case
+
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP) :: xx, yy, zz, rr
+ integer :: i, j, k, direction
+
+ call hit_init
+
+! call parser_read('Scalar direction', direction)
+
+ do i = 1, ns1sc
+ do j = 1, ns2sc
+ do k = 1, ns3sc
+ xx = i*L/ns1sc - L/2
+ yy = j*L/ns2sc - L/2
+ zz = k*L/ns3sc - L/2
+! SC(i,j,k) = sqrt(xx**2.0 + yy**2.0 + zz**2.0)
+! SC(i,j,k) = SC(i,j,k)/SC(1,1,1)
+! if (direction.eq.1) SC(i,j,k) = sin(xx)
+! if (direction.eq.2) SC(i,j,k) = sin(yy)
+! if (direction.eq.3) SC(i,j,k) = sin(zz)
+ rr = sqrt(xx**2.0 + yy**2.0 + zz**2.0)
+ !if (rr.gt.L/6) then
+ ! SC(i,j,k) = 0.0
+ !else
+ ! SC(i,j,k) = 1.0
+ !end if
+ SC(i,j,k) = rr -L/6.
+ !SC(i,j,k) = sin(xx)
+ end do
+ end do
+ end do
+
+
+end subroutine init_test_case
diff --git a/CodesEnVrac/Remesh/FFTPAR/initscal.f90 b/CodesEnVrac/Remesh/FFTPAR/initscal.f90
new file mode 100755
index 0000000000000000000000000000000000000000..46d50f10e37a4c04a9b9a5c1bdc7adf69b09e27b
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/initscal.f90
@@ -0,0 +1,180 @@
+subroutine init_scalar
+
+ use parallel
+ use random
+ use transform
+ use data
+ implicit none
+! include 'fftw3.f'
+
+ ! Spectrum computation
+ real(WP) :: psr,ps1,ps2
+ real(WP) :: ke,kd,ks,dk,ksk0ratio,kc,kcksratio,kk,kx,ky,kz,kk2,kcut
+ real(WP) :: alpha,spec_amp,eps,amp_disc,f_phi,sch
+ integer :: kl,jl,il,impose
+ real(WP) :: e_total,energy_spec,diss_total,ndense
+ real(WP), dimension(:,:), pointer :: spect,sg
+ real(WP), dimension(:), pointer :: s1,s2
+ complex(WP), dimension(:,:,:), pointer :: ak,bk
+ real(WP) :: scmean,scmean_global
+ ! Other
+ integer :: i,j,k,ik,iunit,dim
+ real(WP), dimension(:), pointer :: nnodes
+ complex(WP) :: ii=(0.0_WP,1.0_WP)
+ real(WP) :: rand,pi,spec,kfix
+
+ real(WP) :: keta, Rlambda, L11, tke,L_large, dissipation,eta
+ real(WP) :: e_spec,d_spec, e_local, d_local, spec_factor
+ ! Fourier coefficients
+ real(WP) :: umax,vmax,wmax,cos,sin
+ complex(WP), dimension(:,:,:), pointer :: Uk,Vk,Wk,scalar
+ complex(WP), dimension(:,:,:), pointer :: Cbuf
+ real(WP), dimension(:,:,:), pointer :: Rbuf
+
+ logical :: flg_inplace
+
+ integer :: ierr,gg(3),iforce
+ integer,dimension(:,:,:),pointer :: node_index
+ integer(KIND=8) :: plan_c2r
+
+!!$ real(WP), dimension(:,:,:), pointer :: A
+!!$ complex(WP), dimension(:,:,:), pointer :: B
+
+
+ ! Create pi
+ pi = acos(-1.0_WP)
+ dk = 2.0_WP*pi/L
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Input for scalar field
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ call parser_read('ks/ko', ksk0ratio)
+ ks = ksk0ratio*dk
+!!! Assume kc/ks to be 2 as in Eswaran and Pope
+ kc = 2.0_WP*ks
+
+
+ allocate(scalar(fns1,fns2,fns3))
+
+ scalar = (0.0_WP,0.0_WP)
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ il = i + fnxs - 1
+ jl = j + fnys - 1
+ kl = k + fnzs - 1
+
+ kx=real(il-1,WP)*dk
+ ky=real(jl-1,WP)*dk
+ if (jl.gt.nk) ky=-real(nx-jl+1,WP)*dk
+ kz=real(kl-1,WP)*dk
+ if (kl.gt.nk) kz=-real(nx-kl+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ kk2=sqrt(kx**2+ky**2)
+ if ((ks-dk/2.0_WP.le.kk).and.(kk.le.ks+dk/2.0_WP)) then
+ f_phi = 1.0_WP
+ else
+ f_phi = 0.0_WP
+ endif
+ call random_number(rand)
+ if (kk.lt.1e-10) then
+ scalar(i,j,k) = 0.0_WP
+ else
+ scalar(i,j,k) = sqrt(f_phi/(4.0_WP*pi*kk**2.0_WP))*exp(ii*2.0_WP*pi*rand)
+ endif
+ enddo
+ enddo
+ enddo
+
+ call btran_wrap(scalar,SC,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (SC(i,j,k).le.0.0_WP) then
+ SC(i,j,k) = 0.0_WP
+ else
+ SC(i,j,k) = 1.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(SC,scalar,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ kcut = sqrt(2.0_WP)*real(nx,WP)/3.0_WP
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ il = i + fnxs - 1
+ jl = j + fnys - 1
+ kl = k + fnzs - 1
+
+ kx=real(il-1,WP)*dk
+ ky=real(jl-1,WP)*dk
+ if (jl.gt.nk) ky=-real(nx-jl+1,WP)*dk
+ kz=real(kl-1,WP)*dk
+ if (kl.gt.nk) kz=-real(nx-kl+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ kk2=sqrt(kx**2+ky**2)
+
+ if (kk.gt.kcut) scalar(i,j,k) = 0.0_WP
+
+ if (kk.le.kc) then
+ scalar(i,j,k) = scalar(i,j,k)
+ else
+ scalar(i,j,k) = scalar(i,j,k)*(kc/kk)**2.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+
+ call btran_wrap(scalar,SC,ns1,ns2,ns3,fns1,fns2,fns3)
+ SC = SC/real(ns1**3.0,WP)
+
+
+ call parser_read('Imposing mean gradient',impose,0)
+
+
+ if (impose.eq.1) then
+ scmean = 0.0_WP
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ scmean = scmean + SC(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ALLREDUCE(scmean,scmean_global,1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+ scmean = scmean_global/(real(nx,WP)**3.0_WP)
+
+!!!!!!!!!!!! Setting scalar to zero - see if it lies within bounds
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ SC(i,j,k) = 0.0_WP
+ enddo
+ enddo
+ enddo
+
+ endif
+
+
+
+
+ ! Inverse Fourier transform
+
+ ! Clean up
+ deallocate(scalar)
+
+
+
+end subroutine init_scalar
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/lesmodel.f90 b/CodesEnVrac/Remesh/FFTPAR/lesmodel.f90
new file mode 100755
index 0000000000000000000000000000000000000000..a4098e4253c825d8e7560101b2d85118775ede75
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/lesmodel.f90
@@ -0,0 +1,321 @@
+subroutine dynsmagmodel
+
+ use data
+ use parallel
+ use solver
+
+ integer :: i,j,k
+ real(WP) :: deltx,deltt, cst1, cst2
+ real(WP) :: Ekf,diss_sgs,diss_mu,tau12,mean_uv, nt
+
+ complex(WP), dimension(:,:,:), pointer :: ddxk, ddyk, ddzk
+ real(WP), dimension(:,:,:), pointer :: ddx, ddy, ddz
+
+ real(WP), dimension(:,:,:), pointer :: S11, S12, S13, S22, S23, S33
+ real(WP), dimension(:,:,:), pointer :: L11, L12, L13, L22, L23, L33
+ real(WP), dimension(:,:,:), pointer :: M11, M12, M13, M22, M23, M33
+ real(WP), dimension(:,:,:), pointer :: T11, T12, T13, T22, T23, T33
+ real(WP), dimension(:,:,:), pointer :: R11, R12, R13, R22, R23, R33
+ real(WP), dimension(:,:,:), pointer :: V11, V12, V13, V22, V23, V33
+ real(WP), dimension(:,:,:), pointer :: uft, vft, wft
+ real(WP), dimension(:,:,:), pointer :: dudx, dudy, dudz
+ real(WP), dimension(:,:,:), pointer :: dvdx, dvdy, dvdz
+ real(WP), dimension(:,:,:), pointer :: dwdx, dwdy, dwdz
+ real(WP), dimension(:,:,:), pointer :: normS, normR
+ real(WP), dimension(:,:), pointer :: SPEC1, SPEC11
+ real(WP), dimension(:), pointer :: coefffy, cst1y, cst2y
+
+ deltx = L/(real(nx))
+ deltt = 2*deltx
+ nt = 2.0
+
+ call u_compute
+
+ allocate(dudx(ns1,ns2,ns3))
+ allocate(dudy(ns1,ns2,ns3))
+ allocate(dudz(ns1,ns2,ns3))
+ allocate(dvdx(ns1,ns2,ns3))
+ allocate(dvdy(ns1,ns2,ns3))
+ allocate(dvdz(ns1,ns2,ns3))
+ allocate(dwdx(ns1,ns2,ns3))
+ allocate(dwdy(ns1,ns2,ns3))
+ allocate(dwdz(ns1,ns2,ns3))
+ call gradient(U,0,dudx,dudy,dudz)
+ call gradient(V,0,dvdx,dvdy,dvdz)
+ call gradient(W,0,dwdx,dwdy,dwdz)
+ allocate(S11(ns1,ns2,ns3))
+ allocate(S12(ns1,ns2,ns3))
+ allocate(S13(ns1,ns2,ns3))
+ allocate(S22(ns1,ns2,ns3))
+ allocate(S23(ns1,ns2,ns3))
+ allocate(S33(ns1,ns2,ns3))
+ allocate(normS(ns1,ns2,ns3))
+ S11 = dudx
+ S22 = dvdy
+ S33 = dwdz
+ S12 = 0.5*(dudy+dvdx)
+ S13 = 0.5*(dudz+dwdx)
+ S23 = 0.5*(dvdz+dwdy)
+ normS = sqrt(2.0*(S11*S11 + S22*S22 + S33*S33 + 2.0*S12*S12 + 2.0*S13*S13 + 2.0*S23*S23))
+
+ ! - dyn procedure
+ allocate(R11(ns1,ns2,ns3))
+ allocate(R12(ns1,ns2,ns3))
+ allocate(R13(ns1,ns2,ns3))
+ allocate(R22(ns1,ns2,ns3))
+ allocate(R23(ns1,ns2,ns3))
+ allocate(R33(ns1,ns2,ns3))
+ R11 = normS*S11
+ R12 = normS*S12
+ R13 = normS*S13
+ R22 = normS*S22
+ R23 = normS*S23
+ R33 = normS*S33
+ allocate(V11(ns1,ns2,ns3))
+ allocate(V12(ns1,ns2,ns3))
+ allocate(V13(ns1,ns2,ns3))
+ allocate(V22(ns1,ns2,ns3))
+ allocate(V23(ns1,ns2,ns3))
+ allocate(V33(ns1,ns2,ns3))
+ call specboxfilter(R11,V11,nt)
+ call specboxfilter(R12,V12,nt)
+ call specboxfilter(R13,V13,nt)
+ call specboxfilter(R22,V22,nt)
+ call specboxfilter(R23,V23,nt)
+ call specboxfilter(R33,V33,nt)
+ allocate(uft(ns1,ns2,ns3))
+ allocate(vft(ns1,ns2,ns3))
+ allocate(wft(ns1,ns2,ns3))
+ call specboxfilter(U,uft,nt)
+ call specboxfilter(V,vft,nt)
+ call specboxfilter(W,wft,nt)
+ call gradient(uft,0,dudx,dudy,dudz)
+ call gradient(vft,0,dvdx,dvdy,dvdz)
+ call gradient(wft,0,dwdx,dwdy,dwdz)
+ R11 = dudx
+ R22 = dvdy
+ R33 = dwdz
+ R12 = 0.5*(dudy+dvdx)
+ R13 = 0.5*(dudz+dwdx)
+ R23 = 0.5*(dvdz+dwdy)
+ allocate(normR(ns1,ns2,ns3))
+ normR = 2*sqrt(R11*R11 + R22*R22 + R33*R33 + 2.0*R12*R12 + 2.0*R13*R13 + 2.0*R23*R23)
+ deallocate(dudx)
+ deallocate(dudy)
+ deallocate(dudz)
+ deallocate(dvdx)
+ deallocate(dvdy)
+ deallocate(dvdz)
+ deallocate(dwdx)
+ deallocate(dwdy)
+ deallocate(dwdz)
+ R11 = normR*R11
+ R12 = normR*R12
+ R13 = normR*R13
+ R22 = normR*R22
+ R23 = normR*R23
+ R33 = normR*R33
+ deallocate(normR)
+ allocate(M11(ns1,ns2,ns3))
+ allocate(M12(ns1,ns2,ns3))
+ allocate(M13(ns1,ns2,ns3))
+ allocate(M22(ns1,ns2,ns3))
+ allocate(M23(ns1,ns2,ns3))
+ allocate(M33(ns1,ns2,ns3))
+ M11 = deltt**2.*R11 - deltx**2.*V11
+ M22 = deltt**2.*R22 - deltx**2.*V22
+ M33 = deltt**2.*R33 - deltx**2.*V33
+ M12 = deltt**2.*R12 - deltx**2.*V12
+ M13 = deltt**2.*R13 - deltx**2.*V13
+ M23 = deltt**2.*R23 - deltx**2.*V23
+ deallocate(V11)
+ deallocate(V22)
+ deallocate(V33)
+ deallocate(V12)
+ deallocate(V13)
+ deallocate(V23)
+ allocate(L11(ns1,ns2,ns3))
+ allocate(L12(ns1,ns2,ns3))
+ allocate(L13(ns1,ns2,ns3))
+ allocate(L22(ns1,ns2,ns3))
+ allocate(L23(ns1,ns2,ns3))
+ allocate(L33(ns1,ns2,ns3))
+ R11 = U*U
+ R22 = V*V
+ R33 = W*W
+ R12 = U*V
+ R13 = U*W
+ R23 = V*W
+ call specboxfilter(R11,L11,nt)
+ call specboxfilter(R12,L12,nt)
+ call specboxfilter(R13,L13,nt)
+ call specboxfilter(R22,L22,nt)
+ call specboxfilter(R23,L23,nt)
+ call specboxfilter(R33,L33,nt)
+ L11 = L11 - uft*uft
+ L22 = L22 - vft*vft
+ L33 = L33 - wft*wft
+ L12 = L12 - uft*vft
+ L13 = L13 - uft*wft
+ L23 = L23 - vft*wft
+ deallocate(R11)
+ deallocate(R22)
+ deallocate(R33)
+ deallocate(R12)
+ deallocate(R13)
+ deallocate(R23)
+ deallocate(uft)
+ deallocate(vft)
+ deallocate(wft)
+ L11 = L11*M11 + 2.*L12*M12 + 2.*L13*M13 + L22*M22 + 2.*L23*M23 + L33*M33
+ M11 = M11*M11 + 2.*M12*M12 + 2.*M13*M13 + M22*M22 + 2.*M23*M23 + M33*M33
+ allocate(cst1y(ns2))
+ allocate(cst2y(ns2))
+ allocate(coefffy(ns2))
+ call moyen_y(L11,cst1y)
+ call moyen_y(M11,cst2y)
+ coefffy = cst1y / cst2y
+ deallocate(cst1y)
+ deallocate(cst2y)
+ deallocate(L11)
+ deallocate(L22)
+ deallocate(L33)
+ deallocate(L12)
+ deallocate(L13)
+ deallocate(L23)
+ deallocate(M11)
+ deallocate(M22)
+ deallocate(M33)
+ deallocate(M12)
+ deallocate(M13)
+ deallocate(M23)
+ allocate(T11(ns1,ns2,ns3))
+ allocate(T12(ns1,ns2,ns3))
+ allocate(T13(ns1,ns2,ns3))
+ allocate(T22(ns1,ns2,ns3))
+ allocate(T23(ns1,ns2,ns3))
+ allocate(T33(ns1,ns2,ns3))
+ do j=1,ns2
+ T11(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S11(:,j,:)
+ T12(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S12(:,j,:)
+ T13(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S13(:,j,:)
+ T22(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S22(:,j,:)
+ T23(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S23(:,j,:)
+ T33(:,j,:) = coefffy(j) * deltx**2.0 * normS(:,j,:) * S33(:,j,:)
+ end do
+ deallocate(coefffy)
+
+ ! postprocessing
+ ! Ekf
+ call moyen(U**2.+V**2.+W**2.,cst1)
+ Ekf = cst1/2
+ ! SGS dissipation
+ normS = - ( T11*S11 + T22*S22 + T33*S33 + 2.*T12*S12 + 2.*T13*S13 + 2.*T23*S23 )
+ call moyen(normS,diss_sgs)
+
+ allocate(SPEC1(2,nx+1))
+ allocate(SPEC11(2,nx+1))
+ SPEC1 = 0.0
+ SPEC11 = 0.0
+! call get_spectrum(normS,ns1,ns2,ns3,L,SPEC1,SPEC11)
+! if (rank.eq.0) then
+! open(14,file='spectrum_sgs_diss', form = 'formatted')
+! do i = 1, nx+1
+! if ((SPEC1(1,i).ne.0.0).and.(SPEC1(2,i).ne.0.0)) then
+! write(14,*) SPEC11(1,i), SPEC1(2,i)
+! end if
+! end do
+! end if
+ deallocate(SPEC1)
+ deallocate(SPEC11)
+ ! mu dissipation
+ call moyen( ( S11*S11 + S22*S22 + S33*S33 + 2.*S12*S12 + 2.*S13*S13 + 2.*S23*S23 ),diss_mu)
+ diss_mu = mu_solver * diss_mu
+ ! tau12
+ call moyen((T12)**2.,tau12)
+ ! <uv>
+ call moyen(U*V,mean_uv)
+ if (rank.eq.0) then
+ write(*,'(A10,10(E12.5,3X))') '',sim_time,Ekf,diss_sgs,diss_mu,tau12,mean_uv
+ end if
+
+ deallocate(S11)
+ deallocate(S22)
+ deallocate(S33)
+ deallocate(S12)
+ deallocate(S13)
+ deallocate(S23)
+ deallocate(normS)
+
+ allocate(ddx(ns1,ns2,ns3))
+ allocate(ddy(ns1,ns2,ns3))
+ allocate(ddz(ns1,ns2,ns3))
+ allocate(ddxk(fns1,fns2,fns3))
+ allocate(ddyk(fns1,fns2,fns3))
+ allocate(ddzk(fns1,fns2,fns3))
+ ! -- x
+ ddx = - T11
+ ddy = - T12
+ ddz = - T13
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+ ddxk = ddxk/real((ns1**3.0),WP)
+ ddyk = ddyk/real((ns1**3.0),WP)
+ ddzk = ddzk/real((ns1**3.0),WP)
+ do k = 1, fns3
+ do j = 1, fns2
+ do i = 1, fns1
+ nlx(i,j,k) = nlx(i,j,k) - ii*kx(i)*ddxk(i,j,k) - ii*ky(j)*ddyk(i,j,k) - ii*kz(k)*ddzk(i,j,k)
+ end do
+ end do
+ end do
+ ! -- y
+ ddx = - T12
+ ddy = - T22
+ ddz = - T23
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+ ddxk = ddxk/real((ns1**3.0),WP)
+ ddyk = ddyk/real((ns1**3.0),WP)
+ ddzk = ddzk/real((ns1**3.0),WP)
+ do k = 1, fns3
+ do j = 1, fns2
+ do i = 1, fns1
+ nly(i,j,k) = nly(i,j,k) - ii*kx(i)*ddxk(i,j,k) - ii*ky(j)*ddyk(i,j,k) - ii*kz(k)*ddzk(i,j,k)
+ end do
+ end do
+ end do
+ ! -- z
+ ddx = - T13
+ ddy = - T23
+ ddz = - T33
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+ ddxk = ddxk/real((ns1**3.0),WP)
+ ddyk = ddyk/real((ns1**3.0),WP)
+ ddzk = ddzk/real((ns1**3.0),WP)
+ do k = 1, fns3
+ do j = 1, fns2
+ do i = 1, fns1
+ nlz(i,j,k) = nlz(i,j,k) - ii*kx(i)*ddxk(i,j,k) - ii*ky(j)*ddyk(i,j,k) - ii*kz(k)*ddzk(i,j,k)
+ end do
+ end do
+ end do
+
+ deallocate(T11)
+ deallocate(T22)
+ deallocate(T33)
+ deallocate(T12)
+ deallocate(T13)
+ deallocate(T23)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(ddx)
+ deallocate(ddy)
+ deallocate(ddz)
+
+end subroutine dynsmagmodel
diff --git a/CodesEnVrac/Remesh/FFTPAR/main.f90 b/CodesEnVrac/Remesh/FFTPAR/main.f90
new file mode 100755
index 0000000000000000000000000000000000000000..64b8364e470116fb5cea6c7a8c99ce84f208bea6
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/main.f90
@@ -0,0 +1,107 @@
+subroutine main_init
+
+ use parallel
+ use parser
+ use string
+ implicit none
+
+ character(len=str_long) :: sim_name
+ integer :: itype, ipost, iscal
+
+ call parser_init
+ call parser_parsefile('input')
+
+ call mpi_initialize
+ call random_init
+ call transform_init
+ call data_init
+
+ call parser_read('Simulation name', sim_name)
+ call parser_read('Simulation type', itype)
+ call parser_read('Re-init scalar', iscal)
+
+
+ if (itype.eq.0) then !!!! Initialize and compute
+ if (trim(sim_name).eq.'Taylor Green') then
+ call tg_init
+ elseif(trim(sim_name).eq.'Isotropic turbulence') then
+ call hit_init
+ elseif(trim(sim_name).eq.'Plane jet') then
+ call init_plane_jet
+ elseif(trim(sim_name).eq.'Test case') then
+ call init_test_case
+ else
+ print *,' Unknown Simulation Name'
+ stop
+ endif
+ elseif (itype.eq.1) then
+ call data_read
+ if( iscal.eq.1) then
+ call init_test_case
+ endif
+ else
+ print *,' Unknown simulation type'
+ stop
+ endif
+
+ call solver_init
+
+ call x_advec_init
+
+! call parser_read('Postprocessing', ipost)
+! if (ipost.eq.1) print*,'not yet implemented'
+
+end subroutine main_init
+
+
+program main
+
+ use parallel
+ use parser
+ use string
+ implicit none
+ integer :: i,n_iter
+ character(len=str_long) :: sim_name
+ integer :: ifreq, ipost,itest
+
+ call main_init
+
+ call parser_read('Postprocessing',ipost)
+
+ call parser_read('Simulation iterations',n_iter)
+ call parser_read('Simulation name',sim_name)
+ call parser_read('Write frequency',ifreq,n_iter)
+ if (sim_name.eq.'Isotropic turbulence'.or.sim_name.eq.'Plane jet') call dns_stats
+
+
+
+ if (ipost.eq.1) then
+ call postprocess
+ else if(ipost.eq.2) then
+ call data_filter_sc
+ call data_write
+ stop
+ else if(ipost.eq.5) then
+ call postprocess5
+ stop
+ else if(ipost.eq.6) then
+ call postprocess6
+ stop
+ else if(ipost.eq.7) then
+ call postprocess7
+ stop
+ else
+ call data_write
+ do i = 1,n_iter
+ call solver_step
+ if (trim(sim_name).eq.'Taylor Green') then
+ call tg_stats
+ elseif (trim(sim_name).eq.'Isotropic turbulence'.or.sim_name.eq.'Plane jet') then
+ call dns_stats
+ endif
+ if (mod(i,ifreq).eq.0) call data_write
+ enddo
+! call postprocess
+ end if
+
+end program main
diff --git a/CodesEnVrac/Remesh/FFTPAR/mpi_init.f90 b/CodesEnVrac/Remesh/FFTPAR/mpi_init.f90
new file mode 100755
index 0000000000000000000000000000000000000000..5b7845d17410a3d2f38b3a044e3120d5d2933a90
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/mpi_init.f90
@@ -0,0 +1,185 @@
+module parallel
+
+ implicit none
+ include 'mpif.h'
+
+ integer :: nproc, rank
+
+ integer :: nx,ny,nz
+ integer :: nxsc,nysc,nzsc
+
+ integer :: ns1,ns2,ns3,nk
+ integer :: fns1, fns2, fns3
+
+ integer :: ns1sc,ns2sc,ns3sc,nksc
+ integer :: fns1sc, fns2sc, fns3sc
+
+ integer :: nxs,nxe,nys,nye,nzs,nze
+ integer :: fnxs,fnxe,fnys,fnye,fnzs,fnze
+
+ integer :: nxssc,nxesc,nyssc,nyesc,nzssc,nzesc
+ integer :: fnxssc,fnxesc,fnyssc,fnyesc,fnzssc,fnzesc
+
+
+ integer :: ndim
+
+ integer :: MPI_REAL_WP
+ integer :: MPI_COMPLEX_WP
+
+end module parallel
+
+
+subroutine mpi_initialize
+
+ use precision
+ use parallel
+ use parser
+ implicit none
+
+ integer :: ierr
+ integer :: size_dp
+
+
+ call MPI_INIT(ierr)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,nproc,ierr)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
+
+
+
+ call parser_read('Number of points',nx)
+ ny = nx
+ nz = nx
+
+ if (mod(nz,nproc).ne.0) then
+ print *,' NX should be exactly divided by the number of processors'
+ stop
+ endif
+
+ nk = nx/2+1
+
+ ns1 = nx
+ ns2 = ny
+ ns3 = nz/nproc
+
+ nxs = 1
+ nxe = nx
+
+ nys = 1
+ nye = ny
+
+ nzs = 1 +(rank)*ns3
+ nze = (rank+1)*ns3
+
+
+ fns1 = nk
+ fns2 = ny/nproc
+ fns3 = nz
+
+ fnxs = 1
+ fnxe = nk
+
+ fnys = 1 + (rank)*fns2
+ fnye = (rank+1)*fns2
+
+ fnzs = 1
+ fnze = fns3
+
+!!$
+!!$ print *,' After getdims 11', rank, nxs,nxe,ns1
+!!$ print *,' After getdims 12', rank, nys,nye,ns2
+!!$ print *,' After getdims 13', rank, nzs,nze,ns3
+!!$
+!!$
+!!$
+!!$ print *,' dimensions 31', rank, fnxs, fnxe, fns1
+!!$ print *,' dimensions 32', rank, fnys, fnye, fns2
+!!$ print *,' dimensions 33', rank, fnzs, fnze, fns3
+!!$
+
+
+
+ call parser_read('Number of points for scalar',nxsc)
+ nysc = nxsc
+ nzsc = nxsc
+
+ if (mod(nzsc,nproc).ne.0) then
+ print *,' NXSC should be exactly divided by the number of processors'
+ stop
+ endif
+
+ nksc = nxsc/2+1
+
+ ns1sc = nxsc
+ ns2sc = nysc
+ ns3sc = nzsc/nproc
+
+ nxssc = 1
+ nxesc = nxsc
+
+ nyssc = 1
+ nyesc = nysc
+
+ nzssc = 1 +(rank)*ns3sc
+ nzesc = (rank+1)*ns3sc
+
+ fns1sc = nksc
+ fns2sc = nysc/nproc
+ fns3sc = nzsc
+
+ fnxssc = 1
+ fnxesc = nksc
+
+ fnyssc = 1 + (rank)*fns2sc
+ fnyesc = (rank+1)*fns2sc
+
+ fnzssc = 1
+ fnzesc = fns3sc
+
+
+
+ call MPI_TYPE_SIZE(MPI_DOUBLE_PRECISION,size_dp,ierr)
+ if (WP.eq.size_dp) then
+ MPI_REAL_WP = MPI_DOUBLE_PRECISION
+ else
+ MPI_REAL_WP = MPI_REAL
+ endif
+
+ call MPI_TYPE_SIZE(MPI_DOUBLE_COMPLEX,size_dp,ierr)
+
+ if ((2*WP).eq.size_dp) then
+ MPI_COMPLEX_WP = MPI_DOUBLE_COMPLEX
+ else
+ MPI_COMPLEX_WP = MPI_COMPLEX
+ endif
+
+
+end subroutine mpi_initialize
+
+
+subroutine parallel_max(gmax,mdummy)
+
+ use parallel
+ use precision
+ implicit none
+
+ real(WP) :: gmax, mdummy
+ integer :: ierr
+
+ call MPI_ALLREDUCE(gmax,mdummy,1,MPI_REAL_WP,MPI_MAX,&
+ &MPI_COMM_WORLD,ierr)
+
+ gmax = mdummy
+
+end subroutine parallel_max
+
+subroutine barrier
+
+ use parallel
+
+ implicit none
+
+ integer :: ierr
+
+ call MPI_BARRIER(MPI_COMM_WORLD,ierr)
+
+end subroutine barrier
diff --git a/CodesEnVrac/Remesh/FFTPAR/parinit.f90 b/CodesEnVrac/Remesh/FFTPAR/parinit.f90
new file mode 100755
index 0000000000000000000000000000000000000000..fb92674d905d11b172ce169453ead2fc5e25085c
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/parinit.f90
@@ -0,0 +1,602 @@
+subroutine hit_init
+
+ use parallel
+ use random
+ use transform
+ use data
+ implicit none
+! include 'fftw3.f'
+
+ ! Spectrum computation
+ real(WP) :: psr,ps1,ps2, xx, yy, zz
+ real(WP) :: ke,kd,ks,dk,ksk0ratio,kc,kcksratio,kk,kx,ky,kz,kk2,kcut
+ real(WP) :: alpha,spec_amp,eps,amp_disc,f_phi,sch
+ integer :: kl,jl,il,impose,itype
+ real(WP) :: e_total,energy_spec,diss_total,ndense
+ real(WP), dimension(:,:), pointer :: spect,sg
+ real(WP), dimension(:), pointer :: s1,tabs2
+ complex(WP), dimension(:,:,:), pointer :: ak,bk
+ real(WP) :: scmean,scmean_global
+ ! Other
+ integer :: i,j,k,ik,iunit,dim
+ real(WP), dimension(:), pointer :: nnodes
+ complex(WP) :: ii=(0.0_WP,1.0_WP)
+ real(WP) :: rand,pi,spec,kfix
+
+ real(WP) :: keta, Rlambda, L11, tke,L_large, dissipation,eta
+ real(WP) :: e_spec,d_spec, e_local, d_local, spec_factor
+ ! Fourier coefficients
+ real(WP) :: umax,vmax,wmax,cos,sin
+ complex(WP), dimension(:,:,:), pointer :: Uk,Vk,Wk,scalar
+ complex(WP), dimension(:,:,:), pointer :: Cbuf
+ real(WP), dimension(:,:,:), pointer :: Rbuf
+
+ logical :: flg_inplace
+
+ integer :: ierr,gg(3),iforce,iscal
+ integer,dimension(:,:,:),pointer :: node_index
+ integer(KIND=8) :: plan_c2r
+
+!!$ real(WP), dimension(:,:,:), pointer :: A
+!!$ complex(WP), dimension(:,:,:), pointer :: B
+
+ call parser_read('Kmax eta', keta)
+ call parser_read('R Lambda', Rlambda)
+ call parser_read('Forcing', iforce)
+
+ if (trim(spectrum).eq.'VKP') then
+ call parser_read('Dissipative scale',ld)
+ call parser_read('Dissipation',epsilon)
+ end if
+
+ ! Create pi
+ pi = acos(-1.0_WP)
+
+!!$ ! =================
+!!$ ! Velocity Spectrum
+!!$
+!!$ ! Spectrum computation
+!!$ ke = 2.0_WP*pi/le
+!!$ if (trim(spectrum).eq.'VKP') kd = 2.0_WP*pi/ld
+!!$ dk = 2.0_WP*pi/L
+!!$ kc = real(nx/2,WP)*dk
+!!$ eps=ke/1000000.0_WP
+!!$ if (trim(spectrum).eq.'PP') then
+!!$ spec_amp = 16.0_WP*sqrt(2.0_WP/pi)*Ut**2/ke
+!!$ else if (trim(spectrum).eq.'VKP') then
+!!$ alpha=1.5_WP
+!!$ spec_amp = 1.5_WP*Ut**5/epsilon
+!!$ end if
+!!$ amp_disc = sqrt(dk)**3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!! Modified Input for the Spectral Code
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!! Need to input Viscosity, kmax X eta, R_Lambda
+
+!!!!! Assumes high-reynolds limit to determine the largest eddy
+!!!!! Equations for Pope's book, chapter 6
+
+
+
+ eta = (2.0_WP*keta)/real(nx,WP)
+ L_large = eta*(3.0_WP/20.0_WP*Rlambda*Rlambda)**(3.0/4.0)
+
+ L11 = L_large*0.43
+
+ ke = 1.3_WP/L11
+
+ if (ke.lt.1) then
+ print *,' Peak wavenumber not in the box, reduce R Lambda'
+ call parser_read('Re-init scalar', iscal)
+ if(iscal.eq.0) then
+ stop
+ end if
+ endif
+
+
+ dk = 2.0_WP*pi/L
+ kc = pi*real(nx,WP)/L
+ eps = kc/10000000_WP
+
+
+ e_spec = 0.0_WP
+ d_spec = 0.0_WP
+
+ ndense = 0.0_WP
+
+ do k = fnzs,fnze
+ do j = fnys,fnye
+ do i = fnxs,fnxe
+ kx=real(i-1,WP)*dk
+ ky=real(j-1,WP)*dk
+ if (j.gt.nk) ky=-real(nx+1-j,WP)*dk
+ kz=real(k-1,WP)*dk
+ if (k.gt.nk) kz=-real(nx+1-k,WP)*dk
+ kk=sqrt(kx**2+ky**2+kz**2)
+ if ((kk.gt.eps).and.(kk.le.kc)) then
+ ndense = ndense + 1.0_WP
+ energy_spec = (kk/ke)**4.0_WP*exp(-2.0_WP*(kk/ke)**2.0_WP)/(4.0_WP*pi*kk**2.0_WP)
+ e_spec = e_spec + dk*energy_spec
+ d_spec = d_spec + dk*kk**2.0_WP*energy_spec
+ endif
+ enddo
+ enddo
+ enddo
+
+ e_local = e_spec
+ d_local = d_spec
+ call MPI_ALLREDUCE(e_local,e_spec,1,MPI_REAL_WP,MPI_SUM,&
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(d_local,d_spec,1,MPI_REAL_WP,MPI_SUM,&
+ & MPI_COMM_WORLD,ierr)
+
+
+ spec_amp = 3.0_WP/10.0_WP*Rlambda**2.0_WP*mu**2.0_WP*d_spec/e_spec**2.0_WP
+
+!mu = sqrt(e_spec**2.0_WP/d_spec*(10.0_WP/(3.0_WP*Rlambda**2.0_WP)))
+ tke = spec_amp*e_spec
+
+ Ut = sqrt(tke/1.5_WP) !Rlambda*mu/(sqrt(10.0_WP)*eta**(2.0_WP/3.0_WP)*L_large**(1.0_WP/3.0_WP))
+! tke = 1.5_WP*Ut*Ut
+ dissipation = 2.0_WP*mu*spec_amp*d_spec
+ amp_disc = sqrt(dk)**3.0_WP
+
+
+ if (rank.eq.0) then
+ print *, '------------------------------------------------------------------'
+ print *, '------------------------------------------------------------------'
+ print *,' L11 ', L11
+ print *,' L_large ', L_large
+ print *,' kc ', kc
+ print *,' ke ', ke
+ print *,' eta ', eta
+ print *,' Ut ', Ut
+ print *,' kinetic energy ', tke
+ print *,' dissipation ', dissipation
+ print *,' spec_amp ', spec_amp
+ print *,' amp_disc ', amp_disc
+ print *,' viscosity', mu
+ print *,' e_spec ', e_spec
+ print *,' d_spec ', d_spec
+ print *,' Number of modes', ndense
+ print *,' R lambda calculated', sqrt(20.0_WP/3.0_WP*tke**2.0/(dissipation*mu))
+ print *, '------------------------------------------------------------------'
+ print *, '------------------------------------------------------------------'
+ endif
+
+
+
+ ! Output spectrum for comparison
+ allocate(spect(2,nx+1))
+ e_total=0.0_WP
+ diss_total = 0.0_WP
+ spect = 0.0_WP
+
+
+ ! Compute spectrum
+
+ allocate(ak(fnxs:fnxe,fnys:fnye,fnzs:fnze),bk(fnxs:fnxe,fnys:fnye,fnzs:fnze))
+ !allocate(nnodes(nx+1))
+ !nnodes = 0.0_WP
+ ndense = 0.0_WP
+ do k=fnzs,fnze
+ do j=fnys,fnye
+ do i=fnxs,fnxe
+ ! Random numbers
+ call random_number(rand)
+ psr= 2.0_WP*pi*rand !2.0_WP*pi*(rand-0.5_WP)
+ call random_number(rand)
+ ps1=2.0_WP*pi*rand !*(rand-0.5_WP)
+ call random_number(rand)
+ ps2=2.0_WP*pi*rand !(rand-0.5_WP)
+ ! Wavenumbers
+ kx=real(i-1,WP)*dk
+ ky=real(j-1,WP)*dk
+ if (j.gt.nk) ky=-real(nx+1-j,WP)*dk
+ kz=real(k-1,WP)*dk
+ if (k.gt.nk) kz=-real(nx+1-k,WP)*dk
+ kk=sqrt(kx**2.+ky**2.+kz**2.)
+ ! Spectrums
+ energy_spec=spec_amp*(kk/ke)**4.0_WP*exp(-2.0_WP*(kk/ke)**2.0_WP)
+ ! Coeff
+ ik = 1+idint(kk/dk + 0.5_WP)
+ if ((kk.gt.eps).and.(kk.le.kc)) then
+ ndense = ndense + 1.0_WP
+ ak(i,j,k)= amp_disc*sqrt(energy_spec/(4.0_WP*pi*kk**2.0_WP))*exp(ii*ps1)*cos(psr)
+ bk(i,j,k)= amp_disc*sqrt(energy_spec/(4.0_WP*pi*kk**2.0_WP))*exp(ii*ps2)*sin(psr)
+ spect(2,ik) = spect(2,ik) + real(ak(i,j,k)*conjg(ak(i,j,k))) + real(bk(i,j,k)*conjg(bk(i,j,k)))
+ e_total = e_total + dk*(real(ak(i,j,k)*conjg(ak(i,j,k))) + real(bk(i,j,k)*conjg(bk(i,j,k))))
+ diss_total = diss_total + dk*2.0_WP*mu*kk**2.0_WP*(real(ak(i,j,k)*conjg(ak(i,j,k)))&
+ & + real(bk(i,j,k)*conjg(bk(i,j,k))))
+ end if
+ end do
+ end do
+ end do
+
+ e_local = e_total
+ d_local = diss_total
+ allocate(tabs2(1:nx+1))
+ tabs2 = 0.0_WP
+ call MPI_ALLREDUCE(spect(2,:),tabs2,nx+1,MPI_REAL_WP,MPI_SUM,MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(e_local,e_total,1,MPI_REAL_WP,MPI_SUM,&
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(d_local,diss_total,1,MPI_REAL_WP,MPI_SUM,&
+ & MPI_COMM_WORLD,ierr)
+ spect(2,:) = tabs2
+ deallocate(tabs2)
+
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Total energy ', e_total, tke
+!!$ print *,' Total dissipation ', diss_total, dissipation
+!!$ print *,' Number of modes ', ndense
+!!$ endif
+
+ iunit=iopen()
+ open(iunit,file='spectrum.analytic',form='formatted')
+ do i=1,nx+1
+ spect(1,i) = real(i-1,WP)*dk
+ if ((spect(1,i).ne.0.0_WP).and.(spect(2,i).ne.0.0_WP)) then
+ write(11,*) spect(1,i),',',spect(2,i)
+ end if
+ end do
+ close(iclose(iunit))
+
+
+
+ ! Compute 3D velocity field
+ allocate(Uk(fns1,fns2,fns3))
+ allocate(Vk(fns1,fns2,fns3))
+ allocate(Wk(fns1,fns2,fns3))
+
+ Uk=(0.0_WP,0.0_WP)
+ Vk=(0.0_WP,0.0_WP)
+ Wk=(0.0_WP,0.0_WP)
+
+
+
+ ! Compute the Fourier coefficients
+ do k=fnzs,fnze
+ kl = k - fnzs + 1
+ do j=fnys,fnye
+ jl = j - fnys +1
+ do i=fnxs,fnxe
+
+ ! Wavenumbers
+ kx=real(i-1,WP)*dk
+ ky=real(j-1,WP)*dk
+ if (j.gt.nk) ky=-real(nx-j+1,WP)*dk
+ kz=real(k-1,WP)*dk
+ if (k.gt.nk) kz=-real(nx-k+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ kk2=sqrt(kx**2+ky**2)
+
+ il = i - fnxs+1
+ ! Compute the Fourier coefficients
+ if ((kk.gt.eps).and.(kk.le.kc)) then
+ if (kk2.lt.eps) then
+ Uk(il,jl,kl)=(ak(i,j,k)+bk(i,j,k))/sqrt(2.0_WP)
+ else
+ Uk(il,jl,kl)=(ak(i,j,k)*kk*ky+bk(i,j,k)*kx*kz)/(kk*kk2)
+ end if
+ if (kk2.lt.eps) then
+ Vk(il,jl,kl)=(bk(i,j,k)-ak(i,j,k))/sqrt(2.0_WP)
+ else
+ Vk(il,jl,kl)=(bk(i,j,k)*ky*kz-ak(i,j,k)*kk*kx)/(kk*kk2)
+ end if
+ Wk(il,jl,kl)=-bk(i,j,k)*kk2/kk
+ end if
+ end do
+ end do
+ end do
+
+ deallocate(ak)
+ deallocate(bk)
+
+
+
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$!!!! ODDBALL NOT PROPERLY HANDLED - NEED TO BE FIXED
+!!$!!!! FOR NOW - ONLY THE SIMPLE BOUNDARY (1,1,K) HANDLED
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$
+!!$ ! Oddball
+!!$ do k=2,nx
+!!$ do j=nk+1,nx
+!!$ Uk(1,j,k)=conjg(Uk(1,ny+2-j,nz+2-k))
+!!$ Vk(1,j,k)=conjg(Vk(1,ny+2-j,nz+2-k))
+!!$ Wk(1,j,k)=conjg(Wk(1,ny+2-j,nz+2-k))
+!!$ end do
+!!$ end do
+
+ do k=nk+1,fns3
+ Uk(1,1,k)=conjg(Uk(1,1,nz+2-k))
+ Vk(1,1,k)=conjg(Vk(1,1,nz+2-k))
+ Wk(1,1,k)=conjg(Wk(1,1,nz+2-k))
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ call parser_read('Simulation type',itype)
+ if(itype.eq.0) then
+
+ call btran_wrap(Uk,U,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,V,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,W,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!!!!!!!!
+!! Simple correction to enforce energy spectrum after transform
+!! Convert back to wavenumber space and force spectrum
+!!!!!!!!!
+
+
+
+ call ftran_wrap(U,Uk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(V,Vk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(W,Wk,ns1,ns2,ns3,fns1,fns2,fns3)
+ end if
+
+ Uk = Uk/real(ns1**3.0_WP,WP)
+ Vk = Vk/real(ns1**3.0_WP,WP)
+ Wk = Wk/real(ns1**3.0_WP,WP)
+
+
+ allocate(sg(2,nx+1),s1(nx+1))
+ s1 = 0.0_WP
+ !nnodes = 0
+
+ allocate(node_index(fns1,fns2,fns3))
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ il = i + fnxs -1
+ jl = j + fnys -1
+ kl = k + fnzs -1
+ kx=real(il-1,WP)*dk
+ ky=real(jl-1,WP)*dk
+ if (jl.gt.nk) ky=-real(nx-jl+1,WP)*dk
+ kz=real(kl-1,WP)*dk
+ if (kl.gt.nk) kz=-real(nx-kl+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ ik = 1+idint(kk/dk + 0.5_WP)
+ node_index(i,j,k) = ik
+ if (kk.gt.eps.and.kk.le.kc) then
+ s1(ik) = s1(ik) + real(Uk(i,j,k)*conjg(Uk(i,j,k))) + &
+ & real(Vk(i,j,k)*conjg(Vk(i,j,k))) +&
+ & real(Wk(i,j,k)*conjg(Wk(i,j,k)))
+
+ endif
+ enddo
+ enddo
+ enddo
+
+
+ call MPI_ALLREDUCE(s1,sg(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+ do i = 1,nx+1
+ sg(1,i) = real(i-1,WP)*dk
+ if (sg(2,i).gt.1e-20_WP) then
+ sg(2,i) = spect(2,i)/sg(2,i)
+ else
+ sg(2,i) = 1.0_WP
+ endif
+ enddo
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ Uk(i,j,k) = Uk(i,j,k)*sqrt(sg(2,node_index(i,j,k)))
+ Vk(i,j,k) = Vk(i,j,k)*sqrt(sg(2,node_index(i,j,k)))
+ Wk(i,j,k) = Wk(i,j,k)*sqrt(sg(2,node_index(i,j,k)))
+ enddo
+ enddo
+ enddo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! End of correction
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ call parallel_max(maxval(abs(Uk)),umax)
+ call parallel_max(maxval(abs(Vk)),vmax)
+ call parallel_max(maxval(abs(Wk)),wmax)
+
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Maximum U,V,W after transforms',umax,vmax,wmax
+!!$ endif
+!!$ if (umax.eq.maxval(abs(Uk))) then
+!!$ print *,' In processor rank ', rank
+!!$ print *,' Location of maximum ', maxloc(abs(Uk))
+!!$ gg = maxloc(abs(Uk))
+!!$ print *,' Maximum value ', Uk(gg(1),gg(2),gg(3))
+!!$ endif
+!!$ if (wmax.eq.maxval(abs(Wk))) then
+!!$ print *,' In processor rank ', rank
+!!$ print *,' Location of maximum ', maxloc(abs(Wk))
+!!$ gg = maxloc(abs(Wk))
+!!$ print *,' Maximum value ', Wk(gg(1),gg(2),gg(3))
+!!$ endif
+
+!!$ call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+ if(itype.eq.0) then
+
+ call btran_wrap(Uk,U,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,V,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,W,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ end if
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! End of velocity initialization
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Input for scalar field
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ call parser_read('ks/ko', ksk0ratio)
+ ks = ksk0ratio*dk
+!!! Assume kc/ks to be 2 as in Eswaran and Pope
+ kc = 2.0_WP*ks
+
+
+ allocate(scalar(fns1sc,fns2sc,fns3sc))
+
+ scalar = (0.0_WP,0.0_WP)
+ if(rank.eq.0) print*,'test nksc',nksc
+
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ il = i + fnxssc - 1
+ jl = j + fnyssc - 1
+ kl = k + fnzssc - 1
+
+ kx=real(il-1,WP)*dk
+ ky=real(jl-1,WP)*dk
+ if (jl.gt.nksc) ky=-real(nxsc-jl+1,WP)*dk
+ kz=real(kl-1,WP)*dk
+ if (kl.gt.nksc) kz=-real(nxsc-kl+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ kk2=sqrt(kx**2+ky**2)
+ if ((ks-dk/2.0_WP.le.kk).and.(kk.le.ks+dk/2.0_WP)) then
+ f_phi = 1.0_WP
+ else
+ f_phi = 0.0_WP
+ endif
+ call random_number(rand)
+ if (kk.lt.1e-10) then
+ scalar(i,j,k) = 0.0_WP
+ else
+ scalar(i,j,k) = sqrt(f_phi/(4.0_WP*pi*kk**2.0_WP))*exp(ii*2.0_WP*pi*rand)
+ endif
+ enddo
+ enddo
+ enddo
+
+
+ call btran_wrap(scalar,SC,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ SC = SC/real(ns1sc**3.0,WP)
+
+ do k = 1,ns3sc
+ do j = 1,ns2sc
+ do i = 1,ns1sc
+ if (SC(i,j,k).le.0.0_WP) then
+ SC(i,j,k) = 0.0_WP
+ else
+ SC(i,j,k) = 1.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(SC,scalar,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+! kcut = sqrt(2.0_WP)*real(nxsc,WP)/3.0_WP
+ kcut = real(nx,WP)/2.0_WP
+! kcut = real(nxsc,WP)/2.0_WP
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ il = i + fnxssc - 1
+ jl = j + fnyssc - 1
+ kl = k + fnzssc - 1
+
+ kx=real(il-1,WP)*dk
+ ky=real(jl-1,WP)*dk
+ if (jl.gt.nksc) ky=-real(nxsc-jl+1,WP)*dk
+ kz=real(kl-1,WP)*dk
+ if (kl.gt.nksc) kz=-real(nxsc-kl+1,WP)*dk
+ kk =sqrt(kx**2+ky**2+kz**2)
+ kk2=sqrt(kx**2+ky**2)
+
+ if (kk.gt.kcut) scalar(i,j,k) = 0.0_WP
+
+ if (kk.le.kc) then
+ scalar(i,j,k) = scalar(i,j,k)
+ else
+ scalar(i,j,k) = scalar(i,j,k)*(kc/kk)**2.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+
+ call btran_wrap(scalar,SC,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ SC = SC/real(ns1sc**3.0,WP)
+
+
+ call parser_read('Imposing mean gradient',impose,0)
+
+
+! if (impose.eq.1) then
+! scmean = 0.0_WP
+! do k = 1,ns3
+! do j = 1,ns2
+! do i = 1,ns1
+! scmean = scmean + SC(i,j,k)
+! enddo
+! enddo
+! enddo
+
+! call MPI_ALLREDUCE(scmean,scmean_global,1,MPI_REAL_WP,MPI_SUM,&
+! &MPI_COMM_WORLD,ierr)
+
+! scmean = scmean_global/(real(nx,WP)**3.0_WP)
+
+!!!!!!!!!!!! Setting scalar to zero - see if it lies within bounds
+! do k = 1,ns3
+! do j = 1,ns2
+! do i = 1,ns1
+! SC(i,j,k) = 0.0_WP
+! enddo
+! enddo
+! enddo
+
+! endif
+
+
+ ! Inverse Fourier transform
+
+ ! Clean up
+ deallocate(Uk)
+ deallocate(Vk)
+ deallocate(Wk)
+ deallocate(scalar)
+ deallocate(node_index)
+ deallocate(s1)
+ deallocate(sg)
+ deallocate(spect)
+
+ spfilename = 'spectrum_init'
+ spfilename2 = 'spectrum_init.scalar'
+ call get_dns_numbers(1)
+
+! do i = 1, ns1sc
+! do j = 1, ns2sc
+! do k = 1, ns3sc
+! xx = i*L/ns1sc - L/2
+! yy = j*L/ns2sc - L/2
+! zz = k*L/ns3sc - L/2
+! SC(i,j,k) = sqrt(xx**2.0 + yy**2.0 + zz**2.0)
+! end do
+! end do
+! end do
+
+
+
+! do i = 1, nxsc
+! SC(i,:,:) = sin(real(i)/real(nxsc)*L)
+! end do
+
+
+
+end subroutine hit_init
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/parser.f90 b/CodesEnVrac/Remesh/FFTPAR/parser.f90
new file mode 100755
index 0000000000000000000000000000000000000000..c9b19f0399c3b85f10623d9d14933f81c5666d5d
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/parser.f90
@@ -0,0 +1,428 @@
+module parser
+ use precision
+ implicit none
+
+ ! Input values storage
+ integer, parameter :: tag_length=128
+ integer, parameter :: line_length=40960
+ integer :: nfields
+ type entry_type
+ character(tag_length) :: tag
+ character(line_length) :: value
+ end type entry_type
+ type(entry_type), pointer, dimension(:) :: entries
+
+ ! Define interface for reading
+ interface parser_read
+ module procedure parser_readlogical
+ module procedure parser_readint
+ module procedure parser_readintarray
+ module procedure parser_readfloat
+ module procedure parser_readfloatarray
+ module procedure parser_readfloatarray2D
+ module procedure parser_readchar
+ module procedure parser_readchararray
+ end interface
+
+contains
+
+ ! Pack the structure -----------------------------------------------------
+ subroutine parser_pack(myfield)
+ implicit none
+ integer,intent(in) :: myfield
+ type(entry_type), pointer, dimension(:) :: entries_new
+
+ allocate(entries_new(nfields-1))
+ entries_new(1:myfield-1) = entries(1:myfield-1)
+ entries_new(myfield:nfields-1) = entries(myfield+1:nfields)
+ deallocate(entries)
+ nullify(entries)
+ entries => entries_new
+ nfields = nfields-1
+
+ return
+ end subroutine parser_pack
+
+ ! Spread the structure ---------------------------------------------------
+ subroutine parser_spread
+ implicit none
+ type(entry_type), pointer, dimension(:) :: entries_new
+
+ if (nfields .ne. 0) then
+ allocate(entries_new(nfields+1))
+ entries_new(1:nfields) = entries(1:nfields)
+ deallocate(entries)
+ nullify(entries)
+ entries => entries_new
+ else
+ allocate(entries(1))
+ end if
+ nfields = nfields+1
+
+ return
+ end subroutine parser_spread
+
+ ! Add a new entry in the structure ----------------------------------------
+ subroutine parser_newentry(mytag,myvalue)
+ implicit none
+ character(*),intent(in) :: mytag
+ character(*),intent(in) :: myvalue
+ integer :: ifield
+ logical :: isdef
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ call parser_spread()
+ entries(nfields)%tag=mytag
+ entries(nfields)%value=myvalue
+ else
+ entries(ifield)%value=myvalue
+ end if
+
+ return
+ end subroutine parser_newentry
+
+ ! Get filed number from tag ----------------------------------------------
+ subroutine parser_fieldfortag(mytag,myfield,isdef)
+ implicit none
+ character(*),intent(in) :: mytag
+ integer,intent(out) :: myfield
+ logical,optional,intent(out) :: isdef
+ integer :: ifield
+
+ isdef = .false.
+ do ifield=1,nfields
+ if (entries(ifield)%tag==mytag) then
+ myfield=ifield
+ isdef = .true.
+ return
+ end if
+ end do
+
+ return
+ end subroutine parser_fieldfortag
+
+ ! Check whether the field is defined -------------------------------------
+ subroutine parser_is_defined(mytag,isdef)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ logical,intent(out) :: isdef
+ integer :: ifield
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+
+ return
+ end subroutine parser_is_defined
+
+ ! Read logicals ---------------------------------------------
+ subroutine parser_readlogical(mytag,value,default)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ logical,intent(out) :: value
+ logical,optional,intent(in) :: default
+ integer :: ifield
+ logical :: isdef
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not.isdef .AND. present(default)) then
+ value = default
+ else if (.not.isdef .AND. .not.present(default)) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ else
+ read(entries(ifield)%value,*) value
+ end if
+
+ return
+ end subroutine parser_readlogical
+
+ ! Read integers ---------------------------------------------
+ subroutine parser_readint(mytag,value,default)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ integer,intent(out) :: value
+ integer,optional,intent(in) :: default
+ integer :: ifield
+ logical :: isdef
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not.isdef .AND. present(default)) then
+ value = default
+ else if (.not.isdef .AND. .not.present(default)) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ else
+ read(entries(ifield)%value,*) value
+ end if
+
+ return
+ end subroutine parser_readint
+
+ ! Read floats ---------------------------------------------
+ subroutine parser_readfloat(mytag,value,default)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ real(WP),intent(out) :: value
+ real(WP),optional,intent(in) :: default
+ integer :: ifield
+ logical :: isdef
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not.isdef .AND. present(default)) then
+ value = default
+ else if (.not.isdef .AND. .not.present(default)) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ else
+ read(entries(ifield)%value,*) value
+ end if
+
+ return
+ end subroutine parser_readfloat
+
+ ! Read characters ---------------------------------------------
+ subroutine parser_readchar(mytag,value,default)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ character(len=*),intent(out) :: value
+ character(len=*),optional,intent(in) :: default
+ integer :: ifield
+ logical :: isdef
+
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not.isdef .AND. present(default)) then
+ value = default
+ else if (.not.isdef .AND. .not.present(default)) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ else
+ read(entries(ifield)%value,'(a)') value
+ end if
+
+ return
+ end subroutine parser_readchar
+
+ ! Count size of the arrays ----------------------------------------
+ subroutine parser_getsize(mytag,numb)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ integer,intent(out) :: numb
+ integer :: ifield
+ logical :: isdef
+ integer :: i
+ integer, dimension(line_length) :: counter
+
+ ! Read it now
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ end if
+
+ ! Count the number of entries
+ counter = 0
+ do i=1,len_trim(entries(ifield)%value)
+ if (entries(ifield)%value(i:i).EQ.' ') counter(i)=1
+ end do
+ do i=1+1,len_trim(entries(ifield)%value)
+ if (counter(i).EQ.1 .AND. counter(i-1).EQ.1) counter(i-1)=0
+ end do
+ numb = sum(counter)+1
+
+ return
+ end subroutine parser_getsize
+
+ ! Read integer arrays ---------------------------------------------
+ subroutine parser_readintarray(mytag,value)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ integer,dimension(:),intent(out) :: value
+ integer :: ifield
+ logical :: isdef
+
+ ! Read them
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ end if
+ read(entries(ifield)%value,*) value
+
+ return
+ end subroutine parser_readintarray
+
+ ! Read float arrays ---------------------------------------------
+ subroutine parser_readfloatarray(mytag,value)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ real(WP),dimension(:),intent(out) :: value
+ integer :: ifield
+ logical :: isdef
+
+ ! Read them
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ end if
+ read(entries(ifield)%value,*) value
+
+ return
+ end subroutine parser_readfloatarray
+
+ ! Read float arrays ---------------------------------------------
+ subroutine parser_readfloatarray2D(mytag,value)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ real(WP),dimension(:,:),intent(out) :: value
+ integer :: ifield
+ logical :: isdef
+
+ ! Read them
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ end if
+ read(entries(ifield)%value,*) value
+
+ return
+ end subroutine parser_readfloatarray2D
+
+ ! Read float arrays ---------------------------------------------
+ subroutine parser_readchararray(mytag,value)
+ implicit none
+
+ character(*),intent(in) :: mytag
+ character(*),dimension(:),intent(out) :: value
+ integer :: ifield
+ logical :: isdef
+
+ ! Read them
+ call parser_fieldfortag(mytag,ifield,isdef)
+ if (.not. isdef) then
+ print*,'Parser : '// mytag //' not defined'
+ stop
+ end if
+ read(entries(ifield)%value,*) value
+
+ return
+ end subroutine parser_readchararray
+
+end module parser
+
+! Initialize the parser ---------------------------------------------
+subroutine parser_init
+ use parser
+ use fileio
+ implicit none
+
+ nfields = 0
+ if (associated(entries)) then
+ deallocate(entries)
+ nullify(entries)
+ end if
+
+ return
+end subroutine parser_init
+
+! Read & parse the input file ---------------------------------------------
+subroutine parser_parsefile(input)
+ use parser
+ use fileio
+
+ implicit none
+ integer :: iunit,ierr,limiter,nlines,i,j,ntags,comment
+ integer, dimension(:), allocatable :: limit,line
+ character(len=line_length) :: buffer
+ character(len=line_length), dimension(:), allocatable :: file
+ character(len=line_length) :: value
+ character(len=tag_length) :: tag
+ character(len=*) :: input
+
+ ! Open the file
+ ierr = 0
+ iunit = iopen()
+ open (iunit,file=input,form='formatted',status='old',iostat=ierr)
+ if (ierr .ne. 0) stop 'Parser : an input file is required'
+
+ ! Count the number of lines in the file
+ ierr = 0
+ nlines = 0
+ do while (ierr .eq. 0)
+ read(iunit,'(a)',iostat=ierr) buffer
+ nlines = nlines + 1
+ end do
+ rewind(iunit)
+
+ ! Allocate to the right size
+ allocate(file(nlines+1),limit(nlines+1),line(nlines+1))
+
+ ! Read everything in the buffer
+ ierr = 0
+ nlines = 0
+ loop: do while (ierr .eq. 0)
+ read(iunit,'(a)',iostat=ierr) buffer
+ if (ierr.ne.0) exit loop
+ ! Remove the tabs
+ do j=1,line_length
+ if (ichar(buffer(j:j)).EQ.9) buffer(j:j)=' '
+ end do
+ ! Find comments
+ comment = scan(buffer,'!#%')
+ ! Remove them
+ if (comment.NE.0) buffer(comment:) = ''
+ ! Trim
+ buffer = adjustl(buffer)
+ ! Add line
+ if (len_trim(buffer).NE.0) then
+ nlines = nlines + 1
+ file(nlines) = buffer
+ end if
+ end do loop
+
+ ! Close de file
+ close(iunit)
+ ierr = iclose(iunit)
+
+ ! Get the tags
+ ntags = 0
+ do i=1,nlines
+ limiter = index(file(i),':')
+ if (limiter.NE.0) then
+ ntags = ntags + 1
+ line(ntags) = i
+ line(ntags+1) = nlines+1
+ limit(ntags) = limiter
+ end if
+ end do
+
+ ! Read everything now
+ do i=1,ntags
+ buffer = ''
+ do j=line(i),line(i+1)-1
+ if (j==line(i)) then
+ buffer = trim(buffer) // trim(file(j))
+ else
+ buffer = trim(buffer) // ' ' // trim(file(j))
+ end if
+ end do
+ read(buffer(1:limit(i)-1),'(a)') tag
+ read(buffer(limit(i)+1:),'(a)') value
+ if (len_trim(value).NE.0) then
+ value = adjustl(value)
+ call parser_newentry(tag,value)
+ end if
+ end do
+
+ return
+end subroutine parser_parsefile
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocess.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocess.f90
new file mode 100755
index 0000000000000000000000000000000000000000..4d2deef2882e647800042053be6f7f286aa3a949
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocess.f90
@@ -0,0 +1,219 @@
+subroutine postprocess
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+ integer :: i,j,k,pas, nxo,nxoz
+ character(len=30) :: Filename,pdfufname
+ real(WP) :: nd,nut1,nut2,kt1,kt2
+ real(WP) :: kk,h,nutm,ktm,Am,Bm,Cm,Dm,scht1,scht2,scht3,scht5,pdfscht5,CAm,DBm
+ integer :: ierr,ik,il,jl,kl,iunit
+ real(WP) :: pi,kc,eps,buf,epsil,u2,u3,u4,dudx,lambda,u1,epsil2,eta,sch,eta_B,mini,maxi
+
+ real(WP), dimension(:,:,:), pointer :: Rbuf
+ real(WP), dimension(:,:,:), pointer :: Usc,Vsc,Wsc,Zsc !vitesses sous maillage du scalaire
+ real(WP), dimension(:,:,:), pointer :: T1,T2,T3,diss !flux scalaire
+ real(WP), dimension(:,:,:), pointer :: dZdx, dZdy, dZdz, dZdxsc, dZdysc, dZdzsc
+ real(WP), dimension(:,:,:), pointer :: NUT,SCHT,KT
+ real(WP), dimension(:,:,:), pointer :: tabA,tabB,tabC,tabD
+ real(WP), dimension(:), pointer :: cor,sf2,sf3
+ complex(WP), dimension(:,:,:), pointer :: d11,d12,d13,d22,d23,d33
+ real(WP), dimension(:,:), pointer :: S1,S2,S3,Sg
+ real(WP), dimension(:,:), pointer :: S11,S21,S31,Sg1
+
+
+ real(WP), dimension(:,:,:), pointer :: z
+ real(WP), dimension(:), pointer :: xx,pdf
+ integer :: dime
+
+
+!!! Uk, Vk, Wk and Zk the three component of velocity and scalar in spectral space
+
+ dime = 200
+ allocate(xx(dime))
+ allocate(pdf(dime))
+ call c_pdf_sca(xx,pdf,SC,dime)
+ if(rank.eq.0) then
+ open(14,file='pdf_z',form='formatted')
+ do i=1,dime-1
+ write(14,*) xx(i), pdf(i)
+ enddo
+ close(14)
+ endif
+ deallocate(xx)
+ deallocate(pdf)
+
+
+!!! Energy Spectrum
+ spfilename = 'spectrum.post'
+ spfilename2 = 'spectrum.post.scalar'
+ call get_dns_numbers(1)
+
+
+ if (ns1sc.eq.ns1) then
+
+ call parser_read('Nx filter output',nxo,0)
+
+ nd = real(ns1)/real(nxo)
+ !! on 256^3 just cutfilter
+ allocate(Usc(ns1,ns2,ns3))
+ allocate(Vsc(ns1,ns2,ns3))
+ allocate(Wsc(ns1,ns2,ns3))
+ allocate(Zsc(ns1,ns2,ns3))
+ allocate(T1(ns1,ns2,ns3))
+ allocate(T2(ns1,ns2,ns3))
+ allocate(T3(ns1,ns2,ns3))
+ call speccutfilter(SC,Zsc,nd)
+ call speccutfilter(U,Usc,nd)
+ call speccutfilter(V,Vsc,nd)
+ call speccutfilter(W,Wsc,nd)
+ call speccutfilter(U*SC,T1,nd)
+ call speccutfilter(V*SC,T2,nd)
+ call speccutfilter(W*SC,T3,nd)
+ T1 = T1 - Usc*Zsc
+ T2 = T2 - Vsc*Zsc
+ T3 = T3 - Wsc*Zsc
+ allocate(dZdx(ns1,ns2,ns3))
+ allocate(dZdy(ns1,ns2,ns3))
+ allocate(dZdz(ns1,ns2,ns3))
+ call gradient(Zsc,0.0,dZdx,dZdy,dZdz)
+
+ allocate(diss(ns1,ns2,ns3))
+ diss = T1*dZdx + T2*dZdy + T3*dZdz
+
+ T1 = SC
+ SC = diss
+ file_counter = 1
+ call data_write
+ SC = T1
+ call moyensc(diss,nut1)
+ if (rank.eq.0) print*,'mean diss 256-1 :',nut1
+
+
+ !! on 256^3 cutfilter + cutfilter of product
+ call speccutfilter(U*SC,T1,nd)
+ call speccutfilter(V*SC,T2,nd)
+ call speccutfilter(W*SC,T3,nd)
+ call speccutfilter(Usc*Zsc,diss,nd)
+ T1 = T1 - diss
+ call speccutfilter(Vsc*Zsc,diss,nd)
+ T2 = T2 - diss
+ call speccutfilter(Wsc*Zsc,diss,nd)
+ T3 = T3 - diss
+ call speccutfilter(T1*dZdx,Usc,nd)
+ call speccutfilter(T2*dZdy,Vsc,nd)
+ call speccutfilter(T3*dZdz,Wsc,nd)
+ diss = Usc + Vsc + Wsc
+
+ T1 = SC
+ SC = diss
+ file_counter = 2
+ call data_write
+ SC = T1
+ call moyensc(diss,nut1)
+ if (rank.eq.0) print*,'mean diss 256-2 :',nut1
+
+ deallocate(diss)
+ deallocate(Usc)
+ deallocate(Vsc)
+ deallocate(Wsc)
+ deallocate(Zsc)
+ deallocate(T1)
+ deallocate(T2)
+ deallocate(T3)
+
+ nxoz = nxo / nproc
+ allocate(Usc(nxo,nxo,nxoz))
+ allocate(Vsc(nxo,nxo,nxoz))
+ allocate(Wsc(nxo,nxo,nxoz))
+ allocate(Zsc(nxo,nxo,nxoz))
+ allocate(T1(nxo,nxo,nxoz))
+ allocate(T2(nxo,nxo,nxoz))
+ allocate(T3(nxo,nxo,nxoz))
+
+ call discretisation3(SC,Zsc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(U,Usc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(V,Vsc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(W,Wsc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(U*SC,T1,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(v*SC,T2,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(W*SC,T3,ns1,ns2,ns3,nxo,nxo,nxoz)
+ T1 = T1 - Usc*Zsc
+ T2 = T2 - Vsc*Zsc
+ T3 = T3 - Wsc*Zsc
+
+ allocate(dZdxsc(nxo,nxo,nxoz))
+ allocate(dZdysc(nxo,nxo,nxoz))
+ allocate(dZdzsc(nxo,nxo,nxoz))
+ call gradient(SC,0.0,dZdx,dZdy,dZdz)
+ call discretisation3(dZdx,dZdxsc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(dZdy,dZdysc,ns1,ns2,ns3,nxo,nxo,nxoz)
+ call discretisation3(dZdz,dZdzsc,ns1,ns2,ns3,nxo,nxo,nxoz)
+
+
+ allocate(diss(nxo,nxo,nxoz))
+ diss = T1*dZdxsc + T2*dZdysc + T3*dZdzsc
+
+ nxsc = nxo
+ nysc = nxsc
+ nzsc = nxsc
+
+ if (mod(nzsc,nproc).ne.0) then
+ print *,' NXSC should be exactly divided by the number of processors'
+ stop
+ endif
+
+ nksc = nxsc/2+1
+
+ ns1sc = nxsc
+ ns2sc = nysc
+ ns3sc = nzsc/nproc
+
+ nxssc = 1
+ nxesc = nxsc
+
+ nyssc = 1
+ nyesc = nysc
+
+ nzssc = 1 +(rank)*ns3sc
+ nzesc = (rank+1)*ns3sc
+
+ fns1sc = nksc
+ fns2sc = nysc/nproc
+ fns3sc = nzsc
+
+ fnxssc = 1
+ fnxesc = nksc
+
+ fnyssc = 1 + (rank)*fns2sc
+ fnyesc = (rank+1)*fns2sc
+
+ fnzssc = 1
+ fnzesc = fns3sc
+
+ call random_init
+ call transform_init
+ deallocate(data_storesc)
+ call data_init
+
+ SC = diss
+
+ print*,SC(1,1,1)
+ print*,SC(ns1sc,ns2sc,ns3sc)
+
+ call moyensc(SC,nut1)
+ if (rank.eq.0) print*,'mean diss 64:',nut1
+
+ file_counter = 3
+ call data_write
+
+ else if (ns1sc.lt.ns1) then
+
+ print*,'solver_step'
+ call solver_step
+
+ end if
+
+end subroutine postprocess
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocess5.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocess5.f90
new file mode 100755
index 0000000000000000000000000000000000000000..69e3b5f77bb11b2a10f1d3f59ada6df610f66673
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocess5.f90
@@ -0,0 +1,89 @@
+subroutine postprocess5
+!!! FOR SGS STRESS MODEL
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+ integer :: i,j,k
+ real(WP) :: kk,h,nd,nb,ffsize
+ integer :: ierr,ik,il,jl,kl,iunit,dime,ndd,m1
+ real(WP) :: pi,kc,eps,buf,epsil,u2,u3,u4,dx,cst1,cst2,cst3
+ character*13 filexy1,filexy2,filexy3
+ character*13 filepdf1,filepdf2,filepdf3
+ character*13 filepdf4,filepdf5,filepdf6
+
+ real(WP) :: dudx(ns1,ns2,ns3)
+ real(WP) :: dudy(ns1,ns2,ns3)
+ real(WP) :: dudz(ns1,ns2,ns3)
+ real(WP) :: dvdx(ns1,ns2,ns3)
+ real(WP) :: dvdy(ns1,ns2,ns3)
+ real(WP) :: dvdz(ns1,ns2,ns3)
+ real(WP) :: dwdx(ns1,ns2,ns3)
+ real(WP) :: dwdy(ns1,ns2,ns3)
+ real(WP) :: dwdz(ns1,ns2,ns3)
+ real(WP) :: S11(ns1,ns2,ns3)
+ real(WP) :: S12(ns1,ns2,ns3)
+ real(WP) :: S13(ns1,ns2,ns3)
+ real(WP) :: S22(ns1,ns2,ns3)
+ real(WP) :: S23(ns1,ns2,ns3)
+ real(WP) :: S33(ns1,ns2,ns3)
+ real(WP) :: O11(ns1,ns2,ns3)
+ real(WP) :: O12(ns1,ns2,ns3)
+ real(WP) :: O13(ns1,ns2,ns3)
+ real(WP) :: O22(ns1,ns2,ns3)
+ real(WP) :: O23(ns1,ns2,ns3)
+ real(WP) :: O33(ns1,ns2,ns3)
+ real(WP) :: CQ(ns1,ns2,ns3)
+ real(WP) :: w1(ns1,ns2,ns3)
+ real(WP) :: w2(ns1,ns2,ns3)
+ real(WP) :: w3(ns1,ns2,ns3)
+
+ real(WP) :: xx(500), pdf(500)
+
+ dime = 500
+
+!!! Uk, Vk, Wk and Zk the three component of velocity and scalar in spectral space
+
+!!! All in spatial space
+
+ call gradient(U,0.,dudx,dudy,dudz)
+ call gradient(V,0.,dvdx,dvdy,dvdz)
+ call gradient(W,0.,dwdx,dwdy,dwdz)
+
+ S11 = dudx
+ S22 = dvdy
+ S33 = dwdz
+ S12 = 0.5* (dudy + dvdx)
+ S13 = 0.5* (dudz + dwdx)
+ S23 = 0.5* (dvdz + dwdy)
+ O11 = 0.
+ O22 = 0.
+ O33 = 0.
+ O12 = 0.5* (dudy - dvdx)
+ O13 = 0.5* (dudz - dwdx)
+ O23 = 0.5* (dvdz - dwdy)
+ CQ = 0.5*(O11*O11 - S11*S11 + O22*O22 - S22*S22 + O33*O33 - S33*S33 + &
+ & 2.0*(O12*O12 - S12*S12 + O13*O13 - S13*S13 + O23*O23 - S23*S23))
+ w1 = dwdy - dvdz
+ w2 = dudz - dwdx
+ w3 = dvdx - dudy
+
+ if (rank.eq.0) call dump_geometry
+ if (rank.eq.0) call dump_geometry_scalar
+ call dump_data(U,'paravie_vel_1')
+ call dump_data(V,'paravie_vel_2')
+ call dump_data(W,'paravie_vel_3')
+ call dump_data(w1,'paravie_vor_1')
+ call dump_data(w2,'paravie_vor_2')
+ call dump_data(w3,'paravie_vor_3')
+ call dump_data(CQ,'paravie_critQ')
+ call dump_data_sc(SC,'paravie_scalr')
+ O11 = w1*w1 + w2*w2 + w3*w3
+ O33 = U*U + V*V + W*W
+ call dump_data(O11,'paravie_vor_e')
+ call dump_data(O33,'paravie_vel_e')
+
+
+end subroutine postprocess5
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocess6.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocess6.f90
new file mode 100755
index 0000000000000000000000000000000000000000..9d9b01a6e2988f40e4ec7eaf21cdeb49e70c7d7a
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocess6.f90
@@ -0,0 +1,56 @@
+subroutine postprocess6
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+ integer :: i,j,k,pas,ns1ne,ns2ne,ns3ne
+ character(len=30) :: Filename
+ integer :: ierr,ik,il,jl,kl,iunit
+
+ real(WP), dimension(:,:,:), pointer :: Une,Vne,Wne,Zne ! vitesses pour nouveau maillage
+ integer :: dime
+
+!!! INTEGER
+
+ call parser_read('New discretisation',ns1ne)
+ ns2ne = ns1ne
+ ns3ne = ns1ne/nproc
+
+
+!!! TRANSFOMATION DE LA DISCRETISATION DE NX^3 EN NXNE^3
+
+ if (rank.eq.0) print*,'allocation des tableaux',ns1ne
+ allocate(Une(ns1ne,ns2ne,ns3ne))
+ allocate(Vne(ns1ne,ns2ne,ns3ne))
+ allocate(Wne(ns1ne,ns2ne,ns3ne))
+ allocate(Zne(ns1ne,ns2ne,ns3ne))
+ Une = 0.0
+ Vne = 0.0
+ Wne = 0.0
+ Zne = 0.0
+ if (rank.eq.0) print*,'changement de discretisation U'
+ call discretisation2(U,Une,ns1,ns2,ns3,ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'changement de discretisation V'
+ call discretisation2(V,Vne,ns1,ns2,ns3,ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'changement de discretisation W'
+ call discretisation2(W,Wne,ns1,ns2,ns3,ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'changement de discretisation Z'
+ call discretisation2(SC,Zne,ns1sc,ns2sc,ns3sc,ns1ne,ns2ne,ns3ne)
+
+ if (rank.eq.0) print*,'enregistrement tabU'
+ call tab_write_ne(Une,'tabU.out',ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'enregistrement tabV'
+ call tab_write_ne(Vne,'tabV.out',ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'enregistrement tabW'
+ call tab_write_ne(Wne,'tabW.out',ns1ne,ns2ne,ns3ne)
+ if (rank.eq.0) print*,'enregistrement tabZ'
+ call tab_write_ne(Zne,'tabZ.out',ns1ne,ns2ne,ns3ne)
+
+ deallocate(Une)
+ deallocate(Vne)
+ deallocate(Wne)
+ deallocate(Zne)
+
+end subroutine postprocess6
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocess7.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocess7.f90
new file mode 100755
index 0000000000000000000000000000000000000000..42946de56eb4b39b7c816ca8a602b5f3a3dc5ecd
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocess7.f90
@@ -0,0 +1,156 @@
+subroutine postprocess7
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+ integer :: i,j,k,pas,ns1ne,ns2ne,ns3ne
+ character(len=30) :: Filename
+ integer :: ierr,ik,il,jl,kl,iunit
+
+ real(WP), dimension(:), pointer :: xx,pdf
+ real(WP), dimension(:,:,:), pointer :: convU, convV, convW
+ real(WP), dimension(:,:,:), pointer :: Us1, Vs1, Ws1 , norme
+ real(WP), dimension(:,:,:), pointer :: dudx, dudy, dudz
+ real(WP), dimension(:,:,:), pointer :: dvdx, dvdy, dvdz
+ real(WP), dimension(:,:,:), pointer :: dwdx, dwdy, dwdz
+ integer :: dime
+
+ dime = 200
+
+ !! STEP 1
+ call solver_step
+ call dns_stats
+ if (rank.eq.0) print*,'STEP 1'
+ allocate(Us1(ns1,ns2,ns3))
+ allocate(Vs1(ns1,ns2,ns3))
+ allocate(Ws1(ns1,ns2,ns3))
+ Us1 = U
+ Vs1 = V
+ Ws1 = W
+
+ ! STEP 2
+ if (rank.eq.0) print*,'STEP 2'
+ call solver_step
+ call dns_stats
+ allocate(dudx(ns1,ns2,ns3))
+ allocate(dudy(ns1,ns2,ns3))
+ allocate(dudz(ns1,ns2,ns3))
+ allocate(dvdx(ns1,ns2,ns3))
+ allocate(dvdy(ns1,ns2,ns3))
+ allocate(dvdz(ns1,ns2,ns3))
+ allocate(dwdx(ns1,ns2,ns3))
+ allocate(dwdy(ns1,ns2,ns3))
+ allocate(dwdz(ns1,ns2,ns3))
+
+ if (rank.eq.0) print*,'comput tab'
+ call gradient(U,0.,dudx,dudy,dudz)
+ call gradient(V,0.,dvdx,dvdy,dvdz)
+ call gradient(W,0.,dwdx,dwdy,dwdz)
+
+ if (rank.eq.0) print*,'comput conv term'
+ allocate(convU(ns1,ns2,ns3))
+ allocate(convV(ns1,ns2,ns3))
+ allocate(convW(ns1,ns2,ns3))
+ convU = U*dudx + V*dudy + W*dudz
+ convV = U*dvdx + V*dvdy + W*dvdz
+ convW = U*dwdx + V*dwdy + W*dwdz
+ deallocate(dudx)
+ deallocate(dudy)
+ deallocate(dudz)
+ deallocate(dvdx)
+ deallocate(dvdy)
+ deallocate(dvdz)
+ deallocate(dwdx)
+ deallocate(dwdy)
+ deallocate(dwdz)
+
+ !! STEP 3
+ if (rank.eq.0) print*,'STEP 3'
+ call solver_step
+ call dns_stats
+
+
+ if (rank.eq.0) print*,'acceleration term, dt =', dt
+
+ Us1 = (U - Us1) / (2*dt) + convU
+ Vs1 = (V - Vs1) / (2*dt) + convV
+ Ws1 = (W - Ws1) / (2*dt) + convW
+
+ if (rank.eq.0) print*,'norme'
+ allocate(norme(ns1,ns2,ns3))
+ norme = (Us1*Us1 + Vs1*Vs1 + Ws1*Ws1)**(0.5)
+
+ deallocate(convU)
+ deallocate(convV)
+ deallocate(convW)
+
+ if (rank.eq.0) print*,'PDF'
+ allocate(xx(dime))
+ allocate(pdf(dime))
+ write(FileName,'(A,I2.2,A)') 'pdf_U'
+ call c_pdf(xx,pdf,Us1,dime)
+ if(rank.eq.0) then
+ open(14,file=Filename,form='formatted')
+ do i=1,dime-1
+ write(14,*) xx(i), pdf(i)
+ enddo
+ close(14)
+ endif
+ write(FileName,'(A,I2.2,A)') 'pdf_V'
+ call c_pdf(xx,pdf,Vs1,dime)
+ if(rank.eq.0) then
+ open(14,file=Filename,form='formatted')
+ do i=1,dime-1
+ write(14,*) xx(i), pdf(i)
+ enddo
+ close(14)
+ endif
+ write(FileName,'(A,I2.2,A)') 'pdf_W'
+ call c_pdf(xx,pdf,Ws1,dime)
+ if(rank.eq.0) then
+ open(14,file=Filename,form='formatted')
+ do i=1,dime-1
+ write(14,*) xx(i), pdf(i)
+ enddo
+ close(14)
+ endif
+ write(FileName,'(A,I2.2,A)') 'pdf_nor'
+ call c_pdf(xx,pdf,norme,dime)
+ if(rank.eq.0) then
+ open(14,file=Filename,form='formatted')
+ do i=1,dime-1
+ write(14,*) xx(i), pdf(i)
+ enddo
+ close(14)
+ endif
+ deallocate(xx)
+ deallocate(pdf)
+
+ if (rank.eq.0) print*,'PARAVIEW'
+ call dump_data(Us1,'paravie_acc_1')
+ call dump_data(Vs1,'paravie_acc_2')
+ call dump_data(Ws1,'paravie_acc_3')
+ call dump_data(norme,'paravie_acc_n')
+
+ if( rank.eq.0 ) print*,Us1(1,1,1)
+ if( rank.eq.nproc-1 ) print*,Us1(ns1,ns2,ns3)
+ call tab_write_ne(Us1,'tabaccU.out',ns1,ns2,ns3)
+ if( rank.eq.0 ) print*,Vs1(1,1,1)
+ if( rank.eq.nproc-1 ) print*,Vs1(ns1,ns2,ns3)
+ call tab_write_ne(Vs1,'tabaccV.out',ns1,ns2,ns3)
+ if( rank.eq.0 ) print*,Ws1(1,1,1)
+ if( rank.eq.nproc-1 ) print*,Ws1(ns1,ns2,ns3)
+ call tab_write_ne(Ws1,'tabaccW.out',ns1,ns2,ns3)
+ if( rank.eq.0 ) print*,norme(1,1,1)
+ if( rank.eq.nproc-1 ) print*,norme(ns1,ns2,ns3)
+ call tab_write_ne(norme,'tabaccnorme.out',ns1,ns2,ns3)
+
+
+ deallocate(norme)
+ deallocate(Us1)
+ deallocate(Vs1)
+ deallocate(Ws1)
+
+end subroutine postprocess7
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocessparaview.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocessparaview.f90
new file mode 100755
index 0000000000000000000000000000000000000000..67fc80a1369363f7e7529479138d7e3d3f7531c6
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocessparaview.f90
@@ -0,0 +1,338 @@
+subroutine dump_data(scalar,name)
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(ns1,ns2,ns3) :: scalar
+ character(len=13) :: name
+ character(len=80) :: buffer
+ integer :: iunit,ierr,size,ibuffer, k, kp
+ integer :: fileview,datasize,gdatasize
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(kind=MPI_OFFSET_KIND) :: disp
+ integer :: gsizes(3),lsizes(3),start(3)
+ real(SP), dimension(:,:,:), pointer :: tab
+
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,trim(name),MPI_MODE_WRONLY+MPI_MODE_CREATE,MPI_INFO_NULL,iunit,ierr)
+
+ if (rank.eq.0) then
+ buffer = trim(name)
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ buffer = 'part'
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ ibuffer = 1
+ size = 1
+ call MPI_FILE_WRITE(iunit,ibuffer,size,MPI_INTEGER,status,ierr)
+ buffer = 'block'
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ end if
+
+
+ ! Create the view
+ gsizes(1) = nx
+ gsizes(2) = nx
+ gsizes(3) = nx
+ lsizes(1) = ns1
+ lsizes(2) = ns2
+ lsizes(3) = ns3
+ start(1) = nxs - 1
+ start(2) = nys - 1
+ start(3) = nzs - 1
+ datasize = lsizes(1)*lsizes(2)*lsizes(3)
+ gdatasize= gsizes(1)*gsizes(2)*gsizes(3)
+
+ call MPI_TYPE_CREATE_SUBARRAY(3,gsizes,lsizes,start,MPI_ORDER_FORTRAN,MPI_REAL,fileview,ierr)
+ call MPI_TYPE_COMMIT(fileview,ierr)
+
+ disp = 3*80+4
+ allocate(tab(1:nx,1:nx,nzs:nze))
+ do k = 1,ns3
+ kp = k + rank*ns3
+ tab(:,:,kp) = scalar(:,:,k)
+ end do
+ call MPI_FILE_SET_VIEW(iunit,disp,MPI_REAL,fileview,"native",MPI_INFO_NULL,ierr)
+ call MPI_FILE_WRITE_ALL(iunit,tab,datasize,MPI_REAL,status,ierr)
+
+ call MPI_FILE_CLOSE(iunit,ierr)
+
+end subroutine dump_data
+
+subroutine dump_geometry
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ integer :: ierr,ipart,iunit,i,j,k
+ character(len=80) :: buffer
+ real(SP), dimension(:,:,:), pointer :: xbuf,ybuf,zbuf
+ integer, dimension(:,:,:), pointer :: iblank
+ real(SP) :: max_x,max_y,max_z
+ real(SP) :: min_x,min_y,min_z
+
+ allocate(xbuf(1:nx+1,1:nx+1,1:nx+1),ybuf(1:nx+1,1:nx+1,1:nx+1),zbuf(1:nx+1,1:nx+1,1:nx+1))
+ do i=1,nx+1
+ do j=1,ny+1
+ do k=1,nz+1
+ xbuf(i,j,k)= (real(i)-1.5)*L/real(nx)
+ ybuf(i,j,k)= (real(j)-1.5)*L/real(nx)
+ zbuf(i,j,k)= (real(k)-1.5)*L/real(nx)
+ end do
+ end do
+ end do
+ max_x = maxval(xbuf)
+ max_y = maxval(ybuf)
+ max_z = maxval(zbuf)
+ min_x = minval(xbuf)
+ min_y = minval(ybuf)
+ min_z = minval(zbuf)
+
+ ! Open the file
+ !call BINARY_FILE_OPEN(12345,"geometry","w",ierr)
+ OPEN(UNIT=12345, FILE='geometry', FORM='unformatted',access='stream')
+ REWIND(12345)
+
+ ! Write the geometry
+ buffer = 'C Binary'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'Ensight Gold Geometry File'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'Structured Geometry from ARTS'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'node id off'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'element id off'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'part'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ ipart = 1
+ !call BINARY_FILE_WRITE(12345,ipart,1,kind(ipart),ierr)
+ write(12345) ipart
+
+ buffer = 'Complete geometry'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'block curvilinear iblanked'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ !call BINARY_FILE_WRITE(12345,nx+1,1,kind(nx),ierr)
+ !call BINARY_FILE_WRITE(12345,ny+1,1,kind(ny),ierr)
+ !call BINARY_FILE_WRITE(12345,nz+1,1,kind(nz),ierr)
+ write(12345) nx+1
+ write(12345) ny+1
+ write(12345) nz+1
+
+
+ !call BINARY_FILE_WRITE(12345,xbuf,(nx+1)*(ny+1)*(nz+1),kind(xbuf),ierr)
+ !call BINARY_FILE_WRITE(12345,ybuf,(nx+1)*(ny+1)*(nz+1),kind(ybuf),ierr)
+ !call BINARY_FILE_WRITE(12345,zbuf,(nx+1)*(ny+1)*(nz+1),kind(zbuf),ierr)
+ write(12345) xbuf
+ write(12345) ybuf
+ write(12345) zbuf
+
+ ! Get the iblank in 3D
+ allocate(iblank(nx+1,ny+1,nz+1))
+ do k=1,nz+1
+ iblank(1:nx+1,1:ny+1,k) = 1
+ end do
+ !call BINARY_FILE_WRITE(12345,iblank,(nx+1)*(ny+1)*(nz+1),kind(iblank),ierr)
+ write(12345) iblank
+
+ ! Close the file
+ !call BINARY_FILE_CLOSE(12345,ierr)
+ CLOSE(12345)
+
+end subroutine dump_geometry
+
+subroutine dump_geometry_scalar
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ integer :: ierr,ipart,iunit,i,j,k
+ character(len=80) :: buffer
+ real(SP), dimension(:,:,:), pointer :: xbuf,ybuf,zbuf
+ integer, dimension(:,:,:), pointer :: iblank
+ real(SP) :: max_x,max_y,max_z
+ real(SP) :: min_x,min_y,min_z
+
+ allocate(xbuf(1:nxsc+1,1:nxsc+1,1:nxsc+1),ybuf(1:nxsc+1,1:nxsc+1,1:nxsc+1),zbuf(1:nxsc+1,1:nxsc+1,1:nxsc+1))
+ do i=1,nxsc+1
+ do j=1,nysc+1
+ do k=1,nzsc+1
+ xbuf(i,j,k)= (real(i)-1.5)*L/real(nxsc)
+ ybuf(i,j,k)= (real(j)-1.5)*L/real(nxsc)
+ zbuf(i,j,k)= (real(k)-1.5)*L/real(nxsc)
+ end do
+ end do
+ end do
+ max_x = maxval(xbuf)
+ max_y = maxval(ybuf)
+ max_z = maxval(zbuf)
+ min_x = minval(xbuf)
+ min_y = minval(ybuf)
+ min_z = minval(zbuf)
+
+ print*,"j'y passe"
+
+ ! Open the file
+ !call BINARY_FILE_OPEN(12345,"geomesca","w",ierr)
+ OPEN(UNIT=12345, FILE='geomesca', FORM='unformatted',access='stream')
+ REWIND(12345)
+
+ ! Write the geometry
+ buffer = 'C Binary'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'Ensight Gold Geometry File'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'Structured Geometry from ARTS'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'node id off'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'element id off'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'part'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ ipart = 1
+ !call BINARY_FILE_WRITE(12345,ipart,1,kind(ipart),ierr)
+ write(12345) ipart
+
+ buffer = 'Complete geometry'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ buffer = 'block curvilinear iblanked'
+ !call BINARY_FILE_WRITE(12345,buffer,80,kind(buffer),ierr)
+ write(12345) buffer
+
+ !call BINARY_FILE_WRITE(12345,nxsc+1,1,kind(nxsc),ierr)
+ !call BINARY_FILE_WRITE(12345,nysc+1,1,kind(nysc),ierr)
+ !call BINARY_FILE_WRITE(12345,nzsc+1,1,kind(nzsc),ierr)
+ write(12345) nxsc+1
+ write(12345) nysc+1
+ write(12345) nzsc+1
+
+
+ !call BINARY_FILE_WRITE(12345,xbuf,2*(nysc+1)*(nzsc+1),kind(xbuf),ierr)
+ !call BINARY_FILE_WRITE(12345,ybuf,2*(nysc+1)*(nzsc+1),kind(ybuf),ierr)
+ !call BINARY_FILE_WRITE(12345,zbuf,2*(nysc+1)*(nzsc+1),kind(zbuf),ierr)
+ write(12345) xbuf
+ write(12345) ybuf
+ write(12345) zbuf
+
+ ! Get the iblank in 3D
+ allocate(iblank(nxsc+1,nysc+1,nzsc+1))
+ do k=1,nzsc+1
+ iblank(1:nxsc+1,1:nysc+1,k) = 1
+ end do
+ !call BINARY_FILE_WRITE(12345,iblank,(nxsc+1)*(nysc+1)*(nzsc+1),kind(iblank),ierr)
+ write(12345) iblank
+
+ ! Close the file
+ !call BINARY_FILE_CLOSE(12345,ierr)
+ CLOSE(12345)
+
+end subroutine dump_geometry_scalar
+
+
+subroutine dump_data_sc(scalar,name)
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(ns1sc,ns2sc,ns3sc) :: scalar
+ character(len=13) :: name
+ character(len=80) :: buffer
+ integer :: iunit,ierr,size,ibuffer, k, kp
+ integer :: fileview,datasize,gdatasize
+ integer, dimension(MPI_STATUS_SIZE) :: status
+ integer(kind=MPI_OFFSET_KIND) :: disp
+ integer :: gsizes(3),lsizes(3),start(3)
+ real(SP), dimension(:,:,:), pointer :: tab
+
+ call MPI_FILE_OPEN(MPI_COMM_WORLD,trim(name),MPI_MODE_WRONLY+MPI_MODE_CREATE,MPI_INFO_NULL,iunit,ierr)
+
+ if (rank.eq.0) then
+ buffer = trim(name)
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ buffer = 'part'
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ ibuffer = 1
+ size = 1
+ call MPI_FILE_WRITE(iunit,ibuffer,size,MPI_INTEGER,status,ierr)
+ buffer = 'block'
+ size = 80
+ call MPI_FILE_WRITE(iunit,buffer,size,MPI_CHARACTER,status,ierr)
+ end if
+
+
+ ! Create the view
+ gsizes(1) = nxsc
+ gsizes(2) = nxsc
+ gsizes(3) = nxsc
+ lsizes(1) = ns1sc
+ lsizes(2) = ns2sc
+ lsizes(3) = ns3sc
+ start(1) = nxssc - 1
+ start(2) = nyssc - 1
+ start(3) = nzssc - 1
+ datasize = lsizes(1)*lsizes(2)*lsizes(3)
+ gdatasize= gsizes(1)*gsizes(2)*gsizes(3)
+
+ call MPI_TYPE_CREATE_SUBARRAY(3,gsizes,lsizes,start,MPI_ORDER_FORTRAN,MPI_REAL,fileview,ierr)
+ call MPI_TYPE_COMMIT(fileview,ierr)
+
+ disp = 3*80+4
+ allocate(tab(1:nxsc,1:nxsc,nzssc:nzesc))
+ do k = 1,ns3sc
+ kp = k + rank*ns3sc
+ tab(:,:,kp) = scalar(:,:,k)
+ end do
+ call MPI_FILE_SET_VIEW(iunit,disp,MPI_REAL,fileview,"native",MPI_INFO_NULL,ierr)
+ call MPI_FILE_WRITE_ALL(iunit,tab,datasize,MPI_REAL,status,ierr)
+
+ call MPI_FILE_CLOSE(iunit,ierr)
+
+end subroutine dump_data_sc
diff --git a/CodesEnVrac/Remesh/FFTPAR/postprocesstools.f90 b/CodesEnVrac/Remesh/FFTPAR/postprocesstools.f90
new file mode 100755
index 0000000000000000000000000000000000000000..7a5710b719f3784cadc3ab6852c3b2130c0599a4
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/postprocesstools.f90
@@ -0,0 +1,1480 @@
+subroutine cc_pdf(xx,pdf,z,in2,value,dime)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr
+ real(WP) :: z(ns1,ns2,ns3),umin,umax,umin_recv,umax_recv,delta
+ integer :: in2(ns1,ns2,ns3), value, cpt2, cptt
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin=1.d33
+ umax=-1.d33
+
+ Do k =1,ns3
+ Do j = 1,ns2
+ Do i=1,ns1
+ if (in2(i,j,k).eq.value) then
+ umax = max(umax,z(i,j,k))
+ umin = min(umin,z(i,j,k))
+ end if
+ End Do
+ End Do
+ End Do
+
+ !umax = 5
+ !umin = -5
+
+ Call MPI_ALLREDUCE(umin, umin_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ umin = umin_recv
+ Call MPI_ALLREDUCE(umax, umax_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ umax = umax_recv
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (in2(i,j,k).eq.value) then
+ if (z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if (z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt+1
+ end if
+ end if
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(cptt,cpt2,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ pdf=pdf/(delta*real(cpt2))
+end subroutine cc_pdf
+
+subroutine c_pdf_sca(xx,pdf,z,dime)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr, cpt2, cptt
+ real(WP) :: z(ns1sc,ns2sc,ns3sc),umin,umax,umin_recv,umax_recv,delta
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin=1.d33
+ umax=-1.d33
+
+ Do k =1,ns3sc
+ Do j = 1,ns2sc
+ Do i=1,ns1sc
+ umax = max(umax,z(i,j,k))
+ umin = min(umin,z(i,j,k))
+ End Do
+ End Do
+ End Do
+
+ Call MPI_ALLREDUCE(umin, umin_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ umin = umin_recv
+ Call MPI_ALLREDUCE(umax, umax_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ umax = umax_recv
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3sc
+ do j = 1,ns2sc
+ do i = 1,ns1sc
+ if( z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if( z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt + 1
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(cptt,cpt2,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ pdf=pdf/(delta*real(cpt2))
+end subroutine c_pdf_sca
+
+subroutine c_pdf_sca_fix(xx,pdf,z,dime,mini,maxi)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr, cpt2, cptt
+ real(WP) :: z(ns1sc,ns2sc,ns3sc),umin,umax,umin_recv,umax_recv,delta,mini,maxi
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin = mini
+ umax = maxi
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3sc
+ do j = 1,ns2sc
+ do i = 1,ns1sc
+ if( z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if( z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt + 1
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(cptt,cpt2,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+! pdf=pdf/(delta*real(cpt2))
+ if(rank.eq.0) print*,'nombre de point dans la pdf avec min =',mini, &
+ & ' et max =',maxi, ": ", real(cpt2)/ns1sc**3.*100.," pourcent de points"
+end subroutine c_pdf_sca_fix
+
+subroutine c_pdf(xx,pdf,z,dime)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr, cpt2, cptt
+ real(WP) :: z(ns1,ns2,ns3),umin,umax,umin_recv,umax_recv,delta
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin=1.d33
+ umax=-1.d33
+
+ Do k =1,ns3
+ Do j = 1,ns2
+ Do i=1,ns1
+ umax = max(umax,z(i,j,k))
+ umin = min(umin,z(i,j,k))
+ End Do
+ End Do
+ End Do
+
+ Call MPI_ALLREDUCE(umin, umin_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ umin = umin_recv
+ Call MPI_ALLREDUCE(umax, umax_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ umax = umax_recv
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if( z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if( z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt + 1
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(cptt,cpt2,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ pdf=pdf/(delta*real(cpt2))
+end subroutine c_pdf
+
+subroutine cn_pdf(xx,pdf,z,dnsdiss,dime)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr
+ real(WP) :: dnsdiss(ns1,ns2,ns3),z(ns1,ns2,ns3),umin,umax,umin_recv,umax_recv,delta,cptt
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin=1.d33
+ umax=-1.d33
+
+ Do k =1,ns3
+ Do j = 1,ns2
+ Do i=1,ns1
+ if (dnsdiss(i,j,k).le.0) then
+ umax = max(umax,z(i,j,k))
+ umin = min(umin,z(i,j,k))
+ end if
+ End Do
+ End Do
+ End Do
+
+ Call MPI_ALLREDUCE(umin, umin_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ umin = umin_recv
+ Call MPI_ALLREDUCE(umax, umax_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ umax = umax_recv
+
+ umax = 10.
+ umin = -10.
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (dnsdiss(i,j,k).le.0) then
+ if (z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if (z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt + 1
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ pdf=pdf/(delta*real(cptt))
+end subroutine cn_pdf
+
+subroutine cp_pdf(xx,pdf,z,dnsdiss,dime)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: dime,i,j,k,ll,ierr
+ real(WP) :: dnsdiss(ns1,ns2,ns3),z(ns1,ns2,ns3),umin,umax,umin_recv,umax_recv,delta,cptt
+ real(WP) :: xx(dime), pdf(dime), pdfloc(dime)
+
+
+ umin=1.d33
+ umax=-1.d33
+
+ Do k =1,ns3
+ Do j = 1,ns2
+ Do i=1,ns1
+ if (dnsdiss(i,j,k).gt.0) then
+ umax = max(umax,z(i,j,k))
+ umin = min(umin,z(i,j,k))
+ end if
+ End Do
+ End Do
+ End Do
+
+ Call MPI_ALLREDUCE(umin, umin_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ umin = umin_recv
+ Call MPI_ALLREDUCE(umax, umax_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ umax = umax_recv
+
+ umax = 10.
+ umin = -10.
+
+ pdfloc(:)=0.0
+ cptt = 0
+ delta=(umax-umin)/(dime-1.)
+ if(rank.eq.0) print*,delta,umin,umax
+ do ll = 1,dime-1
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (dnsdiss(i,j,k).gt.0) then
+ if (z(i,j,k) .gt. umin+(ll-1)*delta ) then
+ if (z(i,j,k) .le. umin+ll*delta ) then
+ pdfloc(ll)=pdfloc(ll)+1.
+ cptt = cptt + 1
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ xx(ll)=umin+(ll-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(pdfloc,pdf,dime,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ pdf=pdf/(delta*real(cpTt))
+end subroutine cp_pdf
+
+subroutine var_skew_fla(z,vv,s,f)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: z(ns1,ns2,ns3)
+ real(WP) :: test(ns1,ns2,ns3)
+ real(WP) :: vv,s,f, buf1, buf2, buf3, buf4
+
+ call moyen(z,buf1)
+ call moyen(z**2,buf2)
+ vv = buf2-buf1**2
+ test = (z-buf1)**3
+ call moyen(test,buf3)
+ test = (z-buf1)**4
+ call moyen(test,buf4)
+ s = buf3 / (buf2**(3./2.))
+ f = buf4 / (buf2**(2.))
+end subroutine var_skew_fla
+
+subroutine corre(tab1,tab2,cor)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: cor,moya,moyb
+ real(WP) :: varab,vara2,varb2
+ real(WP) :: tab1(ns1,ns2,ns3)
+ real(WP) :: tab2(ns1,ns2,ns3)
+ call moyen(tab1,moya)
+ call moyen(tab2,moyb)
+ call moyen(tab1*tab2,varab)
+ varab = varab - moya*moyb
+ call moyen(tab1*tab1,vara2)
+ vara2 = vara2 - moya*moya
+ call moyen(tab2*tab2,varb2)
+ varb2 = varb2 - moyb*moyb
+ cor=varab/(sqrt(vara2*varb2));
+end subroutine corre
+
+subroutine moyen_reg1(in1,in2,out1,value)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1,out2
+ real(WP) :: in1(ns1,ns2,ns3)
+ integer :: in2(ns1,ns2,ns3)
+ integer :: i,j,k,ierr, value, cptt, cpt2
+ out2 =0.
+ cpt2 = 0
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (in2(i,j,k).eq.value) then
+ out2=out2+in1(i,j,k)
+ cpt2 = cpt2 + 1
+ end if
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(cpt2,cptt,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(out2,out1,1,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ out1=out1/(real(cptt))
+end subroutine moyen_reg1
+
+subroutine moyen_reg2(in1,in2,out1,value)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1,out2
+ real(WP) :: in1(ns1,ns2,ns3)
+ integer :: in2(ns1,ns2,ns3)
+ integer :: i,j,k,ierr, value, cptt, cpt2
+ out2 =0.
+ cpt2 = 0
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ if (in2(i,j,k).eq.value) then
+ out2=out2+in1(i,j,k)
+ cpt2 = cpt2 + 1
+ end if
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(cpt2,cptt,1,MPI_INTEGER,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(out2,out1,1,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ out1=out1/(real(nx**3))
+end subroutine moyen_reg2
+
+subroutine moyensc(in1,out1)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1,out2
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ integer i,j,k,ierr
+ out2 =0.
+ do k = 1,ns3sc
+ do j = 1,ns2sc
+ do i = 1,ns1sc
+ out2=out2+in1(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(out2,out1,1,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ out1=out1/(real(nxsc**3.))
+end subroutine moyensc
+
+subroutine moyen(in1,out1)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1,out2
+ real(WP) :: in1(ns1,ns2,ns3)
+ integer i,j,k,ierr
+ out2 =0.
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ out2=out2+in1(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(out2,out1,1,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ out1=out1/(real(nx**3.))
+end subroutine moyen
+
+subroutine moyen_ysc(in1,out1)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1(ns2sc),out2(ns2sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ integer i,j,k,ierr
+ out2 =0.
+ do k = 1,ns3sc
+ do j = 1,ns2sc
+ do i = 1,ns1sc
+ out2(j)=out2(j)+in1(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(out2,out1,ns2sc,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+
+ out1=out1/(real(nxsc**2.))
+
+end subroutine moyen_ysc
+
+subroutine moyen_y(in1,out1)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1(ns2),out2(ns2)
+ real(WP) :: in1(ns1,ns2,ns3)
+ integer i,j,k,ierr
+ out2 =0.
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ out2(j)=out2(j)+in1(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(out2,out1,ns2,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+
+ out1=out1/(real(nx**2.))
+
+end subroutine moyen_y
+
+subroutine mean_cond_2(in,cond,cond2,out,nbr)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: nbr,i,j,k,jj,kk,ierr
+ real(WP) :: minix,maxix,delta
+ real(WP) :: minix2,maxix2,delta2
+ real(WP) :: minix_recv,maxix_recv,minix2_recv,maxix2_recv
+ real(WP) :: value(nbr,nbr),valueloc(nbr,nbr)
+ real(WP) :: nombre(nbr,nbr),nombreloc(nbr,nbr)
+ real(WP) :: in(ns1,ns2,ns3)
+ real(WP) :: cond(ns1,ns2,ns3)
+ real(WP) :: cond2(ns1,ns2,ns3)
+ real(WP) :: out(ns1,ns2,ns3)
+ maxix=-1.d33
+ minix=1.d33
+ maxix2=-1.d33
+ minix2=1.d33
+
+ Do k =1,ns3
+ Do j = 1,ns2
+ Do i=1,ns1
+ maxix = max(maxix,cond(i,j,k))
+ minix = min(minix,cond(i,j,k))
+ maxix2 = max(maxix2,cond2(i,j,k))
+ minix2 = min(minix2,cond2(i,j,k))
+ End Do
+ End Do
+ End Do
+
+ Call MPI_ALLREDUCE(minix, minix_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ minix = minix_recv
+ Call MPI_ALLREDUCE(minix2, minix2_recv, 1, MPI_REAL_WP,MPI_MIN, MPI_COMM_WORLD, ierr)
+ minix2 = minix2_recv
+ Call MPI_ALLREDUCE(maxix, maxix_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ maxix = maxix_recv
+ Call MPI_ALLREDUCE(maxix2, maxix2_recv, 1, MPI_REAL_WP,MPI_MAX, MPI_COMM_WORLD, ierr)
+ maxix2 = maxix2_recv
+
+ delta = (maxix-minix)/real(nbr);
+
+ delta2 = (maxix2-minix2)/real(nbr);
+ nombreloc=0.
+ valueloc =0.
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ do jj = 1,nbr
+ do kk = 1,nbr
+ if(cond(i,j,k)>minix+(jj-1)*delta.and.cond(i,j,k)<=minix+jj*delta &
+ & .and.cond2(i,j,k)>minix2+(kk-1)*delta2.and.cond2(i,j,k)<=minix2+kk*delta2 ) then
+ valueloc(jj,kk)=valueloc(jj,kk)+in(i,j,k);
+ nombreloc(jj,kk)=nombreloc(jj,kk)+1;
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(valueloc,value,nbr*nbr,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(nombreloc,nombre,nbr*nbr,MPI_REAL_WP,MPI_SUM, &
+ & MPI_COMM_WORLD,ierr)
+ value=value/nombre
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ do jj = 1,nbr
+ do kk = 1,nbr
+ if(cond(i,j,k)>minix+(jj-1)*delta.and.cond(i,j,k)<=minix+jj*delta &
+ & .and.cond2(i,j,k)>minix2+(kk-1)*delta2.and.cond2(i,j,k)<=minix2+kk*delta2 ) then
+ out(i,j,k)=value(jj,kk)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+end subroutine mean_cond_2
+
+subroutine mean_cond(in,cond,out,xx,value,nbr)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: nbr,i,j,k,jj,ierr
+ real(WP) :: minix,maxix,delta,maxixloc,minixloc
+ real(WP) :: value(nbr),valueloc(nbr),xx(nbr)
+ real(WP) :: nombre(nbr),nombreloc(nbr)
+ real(WP) :: in(ns1,ns2,ns3)
+ real(WP) :: cond(ns1,ns2,ns3)
+ real(WP) :: out(ns1,ns2,ns3)
+ maxixloc = maxval(cond)
+ call MPI_ALLREDUCE(maxixloc,maxix,1,MPI_REAL_WP,MPI_MAX, &
+ MPI_COMM_WORLD,ierr)
+ minixloc = minval(cond)
+ call MPI_ALLREDUCE(minixloc,minix,1,MPI_REAL_WP,MPI_MIN, &
+ MPI_COMM_WORLD,ierr)
+ delta = (maxix-minix)/real(nbr);
+! if(rank.eq.0) print*,maxix
+! if(rank.eq.0) print*,minix
+ nombreloc=0.
+ valueloc =0.
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ do jj = 1,nbr
+ if(cond(i,j,k)>minix+(jj-1)*delta.and.cond(i,j,k)<=minix+jj*delta ) then
+ valueloc(jj)=valueloc(jj)+in(i,j,k);
+ nombreloc(jj)=nombreloc(jj)+1;
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ do jj = 1,nbr
+ xx(jj) = minix+(jj-0.5)*delta
+ enddo
+ call MPI_ALLREDUCE(valueloc,value,nbr,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(nombreloc,nombre,nbr,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ value=value/nombre
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ do jj = 1,nbr
+ if(cond(i,j,k)>minix+(jj-1)*delta.and.cond(i,j,k)<=minix+jj*delta ) then
+ out(i,j,k)=value(jj)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+end subroutine mean_cond
+
+subroutine physboxfilter(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ real(WP) :: dist,nd
+ integer i,j,k,nd2,number
+ integer iii,jj,kk
+ integer id,jd,kd
+
+ nd2=int(nd/2)
+ do k=1,ns1
+ do j=1,ns1
+ do i=1,ns1
+ out1(i,j,k)=0
+ number=0
+ do iii = i-nd2,i+nd2
+ do jj = j-nd2,j+nd2
+ do kk = k-nd2,k+nd2
+ dist = sqrt((real(i)-real(iii))**2.+(real(j)-real(jj))**2.+(real(k)-real(kk))**2.)
+! print*,dist,i,iii,j,jj,k,kk,nd2
+ if (dist.le.real(nd2)) then
+ if(iii.lt.1) then
+ id = ns1+iii
+ elseif(iii.gt.ns1) then
+ id = iii-ns1
+ else
+ id = iii
+ endif
+ if(jj.lt.1) then
+ jd = ns1+jj
+ elseif(j.gt.ns1) then
+ jd = jj-ns1
+ else
+ jd = jj
+ endif
+ if(kk.lt.1) then
+ kd = ns1+kk
+ elseif(kk.gt.ns1) then
+ kd = kk-ns1
+ else
+ kd = kk
+ endif
+ out1(i,j,k)=out1(i,j,k)+in1(id,jd,kd)
+ number=number+1
+ endif
+ enddo
+ enddo
+ enddo
+ out1(i,j,k) = out1(i,j,k)/number
+ enddo
+ enddo
+ enddo
+ print*,'number of points',number
+end subroutine physboxfilter
+
+subroutine specboxfiltersc(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx
+ real(WP) :: out1(ns1sc,ns2sc,ns3sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+
+ dx = L/(real(nxsc))
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(outk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in1,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ delta = nd*dx
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ if(kxsc(i).eq.0.and.kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kxsc(i).eq.0.and.kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kxsc(i).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ elseif(kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))
+ elseif(kxsc(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ endif
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine specboxfiltersc
+
+subroutine specboxfilter(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(outk(fns1,fns2,fns3))
+ call ftran_wrap(in1,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ delta = nd*dx
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ if(kx(i).eq.0.and.ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kx(i).eq.0.and.ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kx(i).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ elseif(ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))
+ elseif(kx(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ endif
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine specboxfilter
+
+subroutine speccutboxfilter2sc(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1sc,ns2sc,ns3sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(outk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in1,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ delta = nd*dx
+ kc = 2*3.141592654/delta
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ if(kxsc(i).eq.0.and.kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kxsc(i).eq.0.and.kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kxsc(i).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ elseif(kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))
+ elseif(kxsc(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ endif
+ enddo
+ enddo
+ enddo
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ kk = sqrt(kxsc(i)**2 + kysc(j)**2 + kzsc(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutboxfilter2sc
+
+subroutine speccutboxfilter2(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(outk(fns1,fns2,fns3))
+ call ftran_wrap(in1,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ delta = nd*dx
+ kc = 2*3.141592654/delta
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ if(kx(i).eq.0.and.ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kx(i).eq.0.and.ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kx(i).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ elseif(ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))
+ elseif(kx(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ endif
+ enddo
+ enddo
+ enddo
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = sqrt(kx(i)**2 + ky(j)**2 + kz(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutboxfilter2
+
+subroutine speccutboxfilter(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(outk(fns1,fns2,fns3))
+ call ftran_wrap(in1,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ delta = nd*dx
+ kc = 3.141592654/delta
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ if(kx(i).eq.0.and.ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kx(i).eq.0.and.ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kx(i).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ elseif(ky(j).eq.0.and.kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))
+ elseif(kx(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(ky(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ elseif(kz(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kx(i))/(0.5*delta*kx(i))* &
+ & sin(0.5*delta*ky(j))/(0.5*delta*ky(j))* &
+ & sin(0.5*delta*kz(k))/(0.5*delta*kz(k))
+ endif
+ enddo
+ enddo
+ enddo
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = sqrt(kx(i)**2 + ky(j)**2 + kz(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutboxfilter
+
+subroutine speccutboxfiltersc(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1sc,ns2sc,ns3sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(outk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in1,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ delta = nd*dx
+ kc = 3.141592654/delta
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ if(kxsc(i).eq.0.and.kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)
+ elseif(kxsc(i).eq.0.and.kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kxsc(i).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ elseif(kysc(j).eq.0.and.kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))
+ elseif(kxsc(i).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kysc(j).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ elseif(kzsc(k).eq.0) then
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))
+ else
+ outk(i,j,k) = ink(i,j,k)*sin(0.5*delta*kxsc(i))/(0.5*delta*kxsc(i))* &
+ & sin(0.5*delta*kysc(j))/(0.5*delta*kysc(j))* &
+ & sin(0.5*delta*kzsc(k))/(0.5*delta*kzsc(k))
+ endif
+ enddo
+ enddo
+ enddo
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ kk = sqrt(kxsc(i)**2 + kysc(j)**2 + kzsc(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutboxfiltersc
+
+
+
+subroutine specgaussfiltersc(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx
+ real(WP) :: out1(ns1sc,ns2sc,ns3sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nxsc))
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(outk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in1,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ delta = nd*dx
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ kk = (kxsc(i)**2 + kysc(j)**2 + kzsc(k)**2)**(0.5)
+ outk(i,j,k) = ink(i,j,k)*exp(-(kk*delta)**2/24.)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine specgaussfiltersc
+
+subroutine specgaussfilter(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(nx))
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(outk(fns1,fns2,fns3))
+ call ftran_wrap(in1,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ delta = nd*dx
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = (kx(i)**2 + ky(j)**2 + kz(k)**2)**(0.5)
+ outk(i,j,k) = ink(i,j,k)*exp(-(kk*delta)**2/24.)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine specgaussfilter
+
+subroutine curl(inx,iny,inz,curlx,curly,curlz)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: i,j,k
+ real(WP) :: inx(ns1,ns2,ns3),iny(ns1,ns2,ns3),inz(ns1,ns2,ns3)
+ real(WP) :: curlx(ns1,ns2,ns3)
+ real(WP) :: curly(ns1,ns2,ns3)
+ real(WP) :: curlz(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: inxk,inyk,inzk,curlxk,curlyk,curlzk
+ ALLOCATE(inxk(fns1,fns2,fns3))
+ ALLOCATE(inyk(fns1,fns2,fns3))
+ ALLOCATE(inzk(fns1,fns2,fns3))
+ ALLOCATE(curlxk(fns1,fns2,fns3))
+ ALLOCATE(curlyk(fns1,fns2,fns3))
+ ALLOCATE(curlzk(fns1,fns2,fns3))
+ call ftran_wrap(inx,inxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(iny,inyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(inz,inzk,ns1,ns2,ns3,fns1,fns2,fns3)
+ inxk=inxk/(real(ns1)**3.)
+ inyk=inyk/(real(ns1)**3.)
+ inzk=inzk/(real(ns1)**3.)
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ curlxk(i,j,k) = ii*ky(j)*inzk(i,j,k) - ii*kz(k)*inyk(i,j,k)
+ curlyk(i,j,k) = ii*kz(k)*inxk(i,j,k) - ii*kx(i)*inzk(i,j,k)
+ curlzk(i,j,k) = ii*kx(i)*inyk(i,j,k) - ii*ky(j)*inxk(i,j,k)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(curlxk,curlx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(curlyk,curly,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(curlzk,curlz,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(curlxk)
+ deallocate(curlyk)
+ deallocate(curlzk)
+ deallocate(inxk)
+ deallocate(inyk)
+ deallocate(inzk)
+end subroutine curl
+
+subroutine gradntsc(in,nd,ddx,ddy,ddz,nt)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: i,j,k
+ integer :: nd, nt
+
+ real(WP) :: in(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddx(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddy(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddz(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink,ddxk,ddyk,ddzk
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddxk(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddyk(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddzk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ ddxk(i,j,k)=(ii*kxsc(i))**(real(nt))*ink(i,j,k)
+ ddyk(i,j,k)=(ii*kysc(j))**(real(nt))*ink(i,j,k)
+ ddzk(i,j,k)=(ii*kzsc(k))**(real(nt))*ink(i,j,k)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(ddxk,ddx,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ call btran_wrap(ddyk,ddy,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ call btran_wrap(ddzk,ddz,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(ink)
+end subroutine gradntsc
+
+subroutine gradientsc(in,nd,ddx,ddy,ddz)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: i,j,k
+ integer :: nd
+
+ real(WP) :: in(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddx(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddy(ns1sc,ns2sc,ns3sc)
+ real(WP) :: ddz(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink,ddxk,ddyk,ddzk
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddxk(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddyk(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(ddzk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ ddxk(i,j,k)=ii*kxsc(i)*ink(i,j,k)
+ ddyk(i,j,k)=ii*kysc(j)*ink(i,j,k)
+ ddzk(i,j,k)=ii*kzsc(k)*ink(i,j,k)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(ddxk,ddx,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ call btran_wrap(ddyk,ddy,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ call btran_wrap(ddzk,ddz,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(ink)
+end subroutine gradientsc
+
+subroutine gradient(in,nd,ddx,ddy,ddz)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: i,j,k
+ integer :: nd
+
+ real(WP) :: in(ns1,ns2,ns3)
+ real(WP) :: ddx(ns1,ns2,ns3)
+ real(WP) :: ddy(ns1,ns2,ns3)
+ real(WP) :: ddz(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink,ddxk,ddyk,ddzk
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(ddxk(fns1,fns2,fns3))
+ ALLOCATE(ddyk(fns1,fns2,fns3))
+ ALLOCATE(ddzk(fns1,fns2,fns3))
+ call ftran_wrap(in,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k)=ii*kx(i)*ink(i,j,k)
+ ddyk(i,j,k)=ii*ky(j)*ink(i,j,k)
+ ddzk(i,j,k)=ii*kz(k)*ink(i,j,k)
+ enddo
+ enddo
+ enddo
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(ink)
+end subroutine gradient
+
+subroutine cutgradient(in,nd,ddx,ddy,ddz)
+ use solver
+ use parallel
+ use data
+ implicit none
+ integer :: i,j,k
+ real(WP) :: nd, kc, delta, dx, kk
+ real(WP) :: in(ns1,ns2,ns3)
+ real(WP) :: ddx(ns1,ns2,ns3)
+ real(WP) :: ddy(ns1,ns2,ns3)
+ real(WP) :: ddz(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink,ddxk,ddyk,ddzk
+ dx = L/(real(nx))
+ delta = nd*dx
+ kc = 3.141592654/delta
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(ddxk(fns1,fns2,fns3))
+ ALLOCATE(ddyk(fns1,fns2,fns3))
+ ALLOCATE(ddzk(fns1,fns2,fns3))
+ call ftran_wrap(in,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k)=ii*kx(i)*ink(i,j,k)
+ ddyk(i,j,k)=ii*ky(j)*ink(i,j,k)
+ ddzk(i,j,k)=ii*kz(k)*ink(i,j,k)
+ kk = sqrt(kx(i)**2 + ky(j)**2 + kz(k)**2)
+ if (kk.gt.kc) then
+ ddxk(i,j,k) = 0.0
+ ddyk(i,j,k) = 0.0
+ ddzk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(ink)
+end subroutine cutgradient
+
+subroutine speccutfilter(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1,ns2,ns3)
+ real(WP) :: in1(ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(ns1))
+ delta = nd*dx
+ kc = 3.141592654/delta
+ ALLOCATE(ink(fns1,fns2,fns3))
+ ALLOCATE(outk(fns1,fns2,fns3))
+ call ftran_wrap(in1,ink,ns1,ns2,ns3,fns1,fns2,fns3)
+ ink=ink/(real(ns1)**3.)
+ outk = ink
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = sqrt(kx(i)**2 + ky(j)**2 + kz(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1,ns2,ns3,fns1,fns2,fns3)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutfilter
+
+
+subroutine speccutfiltersc(in1,out1,nd)
+ use solver
+ use parallel
+ use data
+ implicit none
+ real(WP) :: kk,delta,nd,dx,kc
+ real(WP) :: out1(ns1sc,ns2sc,ns3sc)
+ real(WP) :: in1(ns1sc,ns2sc,ns3sc)
+ complex(WP), dimension(:,:,:), pointer :: ink
+ complex(WP), dimension(:,:,:), pointer :: outk
+ integer i,j,k
+ dx = L/(real(ns1sc))
+ delta = nd*dx
+ kc = 3.141592654/delta
+ ALLOCATE(ink(fns1sc,fns2sc,fns3sc))
+ ALLOCATE(outk(fns1sc,fns2sc,fns3sc))
+ call ftran_wrap(in1,ink,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ ink=ink/(real(ns1sc)**3.)
+ outk = ink
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ kk = sqrt(kxsc(i)**2 + kysc(j)**2 + kzsc(k)**2)
+ if (kk.gt.kc) then
+ outk(i,j,k) = 0.0
+ end if
+ enddo
+ enddo
+ enddo
+ call btran_wrap(outk,out1,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ deallocate(ink)
+ deallocate(outk)
+end subroutine speccutfiltersc
+
+subroutine turbulent_region(t11,t12,t13,t22,t23,t33,ome1,ome2,ome3,out1)
+ use solver
+ use parallel
+ use data
+! use f95_lapack, only: la_syevd
+ implicit none
+
+ integer :: out1(ns1,ns2,ns3)
+ real(WP) :: t11(ns1,ns2,ns3)
+ real(WP) :: t12(ns1,ns2,ns3)
+ real(WP) :: t13(ns1,ns2,ns3)
+ real(WP) :: t22(ns1,ns2,ns3)
+ real(WP) :: t23(ns1,ns2,ns3)
+ real(WP) :: t33(ns1,ns2,ns3)
+ real(WP) :: ome1(ns1,ns2,ns3)
+ real(WP) :: ome2(ns1,ns2,ns3)
+ real(WP) :: ome3(ns1,ns2,ns3)
+ real(WP) :: tab(3,3)
+ real(WP) :: vec(3)
+ real(WP) :: norm, sca1, sca2, sca3, scamax, lp, lm
+
+ integer :: i, j, k
+
+ do k = 1, ns3
+ do j = 1, ns2
+ do i = 1, ns1
+ norm = sqrt(ome1(i,j,k)**2.0 + ome2(i,j,k)**2.0 + ome3(i,j,k)**2.0)
+ ome1(i,j,k) = ome1(i,j,k) / norm
+ ome2(i,j,k) = ome2(i,j,k) / norm
+ ome3(i,j,k) = ome3(i,j,k) / norm
+ norm = sqrt(ome1(i,j,k)**2.0 + ome2(i,j,k)**2.0 + ome3(i,j,k)**2.0)
+ if ( norm.le.0.999.or.norm.ge.1.001) then
+ print*,'norm vorticity',sqrt(ome1(i,j,k)**2.0 + ome2(i,j,k)**2.0 + ome3(i,j,k)**2.0),i,j,k
+ end if
+ end do
+ end do
+ end do
+
+ out1 = 0.
+
+ do k = 1, ns3
+ do j = 1, ns2
+ do i = 1, ns1
+
+ tab(1,1) = t11(i,j,k)
+ tab(1,2) = t12(i,j,k)
+ tab(2,1) = t12(i,j,k)
+ tab(1,3) = t13(i,j,k)
+ tab(3,1) = t13(i,j,k)
+ tab(2,2) = t22(i,j,k)
+ tab(2,3) = t23(i,j,k)
+ tab(3,2) = t23(i,j,k)
+ tab(3,3) = t33(i,j,k)
+ vec = 0.
+
+! call la_syevd(tab,vec,'V')
+
+ norm = sqrt( tab(1,1)**2.0 + tab(2,1)**2.0 + tab(3,1)**2.0 )
+ if (norm.le.0.999.or.norm.ge.1.001) print*,'norm vec1', norm, i,j,k
+ norm = sqrt( tab(1,2)**2.0 + tab(2,2)**2.0 + tab(3,2)**2.0 )
+ if (norm.le.0.999.or.norm.ge.1.001) print*,'norm vec2', norm, i,j,k
+ norm = sqrt( tab(1,3)**2.0 + tab(2,3)**2.0 + tab(3,3)**2.0 )
+ if (norm.le.0.999.or.norm.ge.1.001) print*,'norm vec3', norm, i,j,k
+
+ !if (rank.eq.0) then
+ ! print*,'eigenvector (',tab(1,1),tab(2,1),tab(3,1),') of eigenvector: ',vec(1)
+ ! print*,'eigenvector (',tab(1,2),tab(2,2),tab(3,2),') of eigenvector: ',vec(2)
+ ! print*,'eigenvector (',tab(1,3),tab(2,3),tab(3,3),') of eigenvector: ',vec(3)
+ !end if
+ if (vec(2).gt.vec(3).or.vec(2).lt.vec(1)) then
+ print*, 'pas le bon ordre pour les valeurs propres', rank,i,j,k
+ end if
+
+ sca1 = ome1(i,j,k)*tab(1,1) + ome2(i,j,k)*tab(2,1) + ome3(i,j,k)*tab(3,1)
+ sca2 = ome1(i,j,k)*tab(1,2) + ome2(i,j,k)*tab(2,2) + ome3(i,j,k)*tab(3,2)
+ sca3 = ome1(i,j,k)*tab(1,3) + ome2(i,j,k)*tab(2,3) + ome3(i,j,k)*tab(3,3)
+
+ scamax = max(abs(sca1),abs(sca2))
+ scamax = max(scamax,abs(sca3))
+
+ if (scamax.le.0.5.or.scamax.ge.1.001) print*,'SCAMAX',scamax
+
+ if (scamax.eq.sca1) then
+ lp = vec(3)
+ lm = vec(2)
+ else if (scamax.eq.sca2) then
+ lp = vec(3)
+ lm = vec(1)
+ else if (scamax.eq.sca3) then
+ lp = vec(2)
+ lm = vec(1)
+ end if
+
+ if (lm.gt.0) out1(i,j,k)=1 ! strain dominated region
+ if (lp.ge.0.and.lm.le.0) out1(i,j,k)=2 !strain rate and vorticity comparable
+ if (lp.lt.0) out1(i,j,k)=3 ! vorticity dominated region
+
+ end do
+ end do
+ end do
+
+end subroutine turbulent_region
diff --git a/CodesEnVrac/Remesh/FFTPAR/precision.f90 b/CodesEnVrac/Remesh/FFTPAR/precision.f90
new file mode 100755
index 0000000000000000000000000000000000000000..aeaef73223f539027fa7cea2039bced95cf78efc
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/precision.f90
@@ -0,0 +1,11 @@
+module precision
+ implicit none
+ integer, parameter :: SP = kind(1.0)
+ integer, parameter, private :: DP = kind(1.0d0)
+ integer, parameter :: WP = DP
+ real(WP), private :: sample_real_at_WP
+ real(WP), parameter :: MAX_REAL_WP = HUGE(sample_real_at_WP)
+ integer, private :: sample_int
+ integer, parameter :: MAX_INTEGER = HUGE(sample_int)
+
+end module precision
diff --git a/CodesEnVrac/Remesh/FFTPAR/random.f90 b/CodesEnVrac/Remesh/FFTPAR/random.f90
new file mode 100755
index 0000000000000000000000000000000000000000..e1741bebf0b96d740566ad75c9e2da2f14a291ab
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/random.f90
@@ -0,0 +1,119 @@
+module random
+ use precision
+ implicit none
+
+contains
+
+ ! ------------------------------------------------------------------ !
+ ! Normal distribution !
+ ! Adapted from the following Fortran 77 code !
+ ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. !
+ ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, !
+ ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. !
+ ! The function random_normal() returns a normally distributed !
+ ! pseudo-random number with zero mean and unit variance. !
+ ! The algorithm uses the ratio of uniforms method of A.J. Kinderman !
+ ! and J.F. Monahan augmented with quadratic bounding curves. !
+ ! ------------------------------------------------------------------ !
+ real(WP) function random_normal(m,sd)
+ implicit none
+
+ real(WP), intent(in), optional :: m
+ real(WP), intent(in), optional :: sd
+ real(WP) :: s = 0.449871_WP
+ real(WP) :: t = -0.386595_WP
+ real(WP) :: a = 0.19600_WP
+ real(WP) :: b = 0.25472_WP
+ real(WP) :: r1 = 0.27597_WP
+ real(WP) :: r2 = 0.27846_WP
+ real(WP) :: u,v,x,y,q
+
+ ! Generate P = (u,v) uniform in rectangle enclosing acceptance region
+ do
+ call random_number(u)
+ call random_number(v)
+ v=1.7156_WP*(v-0.5_WP)
+ ! Evaluate the quadratic form
+ x=u-s
+ y=abs(v)-t
+ q=x**2+y*(a*y-b*x)
+ ! Accept P if inside inner ellipse
+ if (q<r1) exit
+ ! Reject P if outside outer ellipse
+ if (q>r2) cycle
+ ! Reject P if outside acceptance region
+ if (v**2<-4.0_WP*log(u)*u**2) exit
+ end do
+
+ ! Return ratio of P's coordinates as the normal deviate
+ random_normal = v/u
+
+ ! Modify to give correct mean and standard deviation
+ if (present(sd)) random_normal = random_normal*sd
+ if (present(m)) random_normal = random_normal+m
+
+ return
+ end function random_normal
+
+ ! ---------------------------------------------------------------------------- !
+ ! Log-normal distribution !
+ ! If X has a lognormal distribution, then log(X) is normally distributed. !
+ ! Here the logarithm is the natural logarithm, that is to base e, sometimes !
+ ! denoted as ln. To generate random variates from this distribution, generate !
+ ! a random deviate from the normal distribution with mean and variance equal !
+ ! to the mean and variance of the logarithms of X, then take its exponential. !
+ ! !
+ ! Relationship between the mean & variance of log(X) and the mean & variance !
+ ! of X, when X has a lognormal distribution. !
+ ! Let m = mean of log(X), and s^2 = variance of log(X) !
+ ! Then !
+ ! mean of X = exp(m + 0.5s^2) !
+ ! variance of X = (mean(X))^2.[exp(s^2) - 1] !
+ ! !
+ ! In the reverse direction !
+ ! variance of log(X) = log[1 + var(X)/(mean(X))^2] !
+ ! mean of log(X) = log(mean(X) - 0.5var(log(X)) !
+ ! ---------------------------------------------------------------------------- !
+ real(WP) function random_lognormal(m,sd)
+ implicit none
+
+ real(WP), intent(in) :: m
+ real(WP), intent(in) :: sd
+ real(WP) :: x,mlog,sdlog
+
+ sdlog = sqrt(log(1.0_WP+(sd/m)**2))
+ mlog = log(m)-0.5_WP*sdlog**2
+ x = random_normal(mlog,sdlog)
+ random_lognormal = exp(x)
+
+ return
+ end function random_lognormal
+
+end module random
+
+
+! ------------------------- !
+! Initialization of the RNG !
+! Seeded based on parallel !
+! partitioning !
+! ------------------------- !
+subroutine random_init
+ use parallel
+ use random
+ implicit none
+
+ integer :: k
+ integer, dimension(:), allocatable :: seed
+
+ call RANDOM_SEED(size=k)
+ allocate(seed(k))
+ call system_clock(count=seed(1))
+ seed(1:k) = seed(1:k)*(rank+1)
+ call RANDOM_SEED(put=seed)
+ deallocate(seed)
+
+
+
+ return
+end subroutine random_init
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/solver.f90 b/CodesEnVrac/Remesh/FFTPAR/solver.f90
new file mode 100755
index 0000000000000000000000000000000000000000..7d98b8c23eda8a2ad44883a13e8fc5988381210b
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/solver.f90
@@ -0,0 +1,970 @@
+module solver
+
+ use precision
+
+ implicit none
+
+ real(WP), dimension(:), allocatable :: kx
+ real(WP), dimension(:), allocatable :: ky
+ real(WP), dimension(:), allocatable :: kz
+
+ real(WP), dimension(:), allocatable :: kxsc
+ real(WP), dimension(:), allocatable :: kysc
+ real(WP), dimension(:), allocatable :: kzsc
+
+ integer :: deal
+ real(WP) :: dk,kmax,kcut
+ real(WP) :: kmaxsc,kcutsc
+
+ real(WP) :: mu_solver, diff_solver
+ real(WP) :: courant
+
+ integer :: iforce,iscalar,iles,ilessc,ydir,ipost
+
+
+ complex(WP), dimension(:,:,:), allocatable :: Uk
+ complex(WP), dimension(:,:,:), allocatable :: Vk
+ complex(WP), dimension(:,:,:), allocatable :: Wk
+ complex(WP), dimension(:,:,:), allocatable :: Zk
+
+ complex(WP), dimension(:,:,:),pointer :: Udummy
+ complex(WP), dimension(:,:,:),pointer :: Vdummy
+ complex(WP), dimension(:,:,:),pointer :: Wdummy
+ complex(WP), dimension(:,:,:),pointer :: Zdummy
+
+ complex(WP), dimension(:,:,:), allocatable :: nlx
+ complex(WP), dimension(:,:,:), allocatable :: nly
+ complex(WP), dimension(:,:,:), allocatable :: nlz
+ complex(WP), dimension(:,:,:), allocatable :: nlmf
+
+ complex(WP), dimension(:,:,:), allocatable :: nlu2x
+ complex(WP), dimension(:,:,:), allocatable :: nlu2y
+ complex(WP), dimension(:,:,:), allocatable :: nlu2z
+
+
+
+ logical, parameter :: flg_inplace = .false.
+ complex(WP), parameter :: ii = (0.0_WP,1.0_WP)
+ real(WP), parameter :: kmin = 1e-06_WP
+
+ real(WP) :: dt,sim_time
+
+ integer :: impose
+ real(WP) :: cx,cy,cz
+
+end module solver
+
+
+subroutine solver_init
+
+ use parallel
+ use data
+ use solver
+ use transform
+
+ implicit none
+
+ integer :: i,j,k,il,jl,kl,gg(3),itype
+ real(WP) :: pi
+ real(WP) :: umax,vmax,wmax
+
+
+ allocate(kx(fns1))
+ allocate(ky(fns2))
+ allocate(kz(fns3))
+
+ allocate(kxsc(fns1sc))
+ allocate(kysc(fns2sc))
+ allocate(kzsc(fns3sc))
+
+ pi = acos(-1.0_WP)
+ dk = 2.0_WP*pi/L
+
+ do i = fnxs,fnxe
+ il = i -fnxs+1
+ kx(il) = real((i-1),WP)*dk
+ enddo
+ do i = fnxssc,fnxesc
+ il = i -fnxssc+1
+ kxsc(il) = real((i-1),WP)*dk
+ enddo
+
+ do j = fnys,fnye
+ jl = j - fnys +1
+ ky(jl) = real((j-1),WP)*dk
+ if (j.gt.nk) ky(jl) = -real(nx+1-j,WP)*dk
+ enddo
+ do j = fnyssc,fnyesc
+ jl = j - fnyssc +1
+ kysc(jl) = real((j-1),WP)*dk
+ if (j.gt.nksc) kysc(jl) = -real(nxsc+1-j,WP)*dk
+ enddo
+
+ do k = fnzs,fnze
+ kl = k -fnzs+1
+ kz(kl) = real((k-1),WP)*dk
+ if (k.gt.nk) kz(kl) = -real(nx+1-k,WP)*dk
+ enddo
+ do k = fnzssc,fnzesc
+ kl = k -fnzssc+1
+ kzsc(kl) = real((k-1),WP)*dk
+ if (k.gt.nksc) kzsc(kl) = -real(nxsc+1-k,WP)*dk
+ enddo
+
+
+! print *,'First checkpoint',rank
+
+
+ allocate(Uk(fns1,fns2,fns3))
+ allocate(Vk(fns1,fns2,fns3))
+ allocate(Wk(fns1,fns2,fns3))
+ allocate(Zk(fns1sc,fns2sc,fns3sc))
+
+ allocate(Udummy(fns1,fns2,fns3))
+ allocate(Vdummy(fns1,fns2,fns3))
+ allocate(Wdummy(fns1,fns2,fns3))
+!!PAR!! allocate(Zdummy(fns1sc,fns2sc,fns3sc))
+
+
+
+ call ftran_wrap(U,Uk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(V,Vk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(W,Wk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(SC,Zk,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+
+ Uk = Uk/real(nx**3.0,WP)
+ Vk = Vk/real(nx**3.0,WP)
+ Wk = Wk/real(nx**3.0,WP)
+ Zk = Zk/real(nxsc**3.0,WP)
+
+ call parallel_max(maxval(abs(Uk)),umax)
+ call parallel_max(maxval(abs(Vk)),vmax)
+ call parallel_max(maxval(abs(Wk)),wmax)
+
+ if (rank.eq.0) then
+ print *,' Maximum of U,V,W after trans',umax,vmax,wmax
+ endif
+
+
+
+!!$ call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+ allocate(nlx(fns1,fns2,fns3))
+ allocate(nly(fns1,fns2,fns3))
+ allocate(nlz(fns1,fns2,fns3))
+!!PAR!! allocate(nlmf(fns1sc,fns2sc,fns3sc))
+ allocate(nlu2x(fns1,fns2,fns3))
+ allocate(nlu2y(fns1,fns2,fns3))
+ allocate(nlu2z(fns1,fns2,fns3))
+
+!!$
+!!$ call parallel_max(maxval(abs(Uk)),umax)
+!!$ call parallel_max(maxval(abs(Vk)),vmax)
+!!$ call parallel_max(maxval(abs(Wk)),wmax)
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Maximum U,V,W in solver',umax,vmax,wmax
+!!$ endif
+!!$
+!!$ if (umax.eq.maxval(abs(Uk))) then
+!!$ print *,' Maximum in rank', rank
+!!$ print *,' location ', maxloc(abs(Uk))
+!!$ gg = maxloc(abs(Uk))
+!!$ print *,' max value for conformation', Uk(gg(1),gg(2),gg(3))
+!!$ endif
+!!$
+!!$ if (wmax.eq.maxval(abs(Wk))) then
+!!$ print *,' Maximum in rank W', rank
+!!$ print *,' location W', maxloc(abs(Wk))
+!!$ gg = maxloc(abs(Wk))
+!!$ print *,' max value for W conformation', Wk(gg(1),gg(2),gg(3))
+!!$ endif
+
+ sim_time = 0.0_WP
+
+ call parser_read('Dealiasing',deal,0)
+
+ kmax = sqrt(3.0_WP)*kx(nx/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+!!PAR!! kmaxsc = sqrt(3.0_WP)*kxsc(nxsc/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+ if (deal.eq.1) then
+ kcut = 2.0_WP/3.0_WP*kmax
+!!PAR!! kcutsc = 2.0_WP/3.0_WP*kmaxsc
+ else
+ kcut = 10000.0_WP
+!!PAR!! kcutsc = 10000.0_WP
+ endif
+
+ mu_solver = mu
+ diff_solver = diff
+
+ call parser_read('LES model',iles,0)
+ call parser_read('LES scalar model',ilessc,0)
+ call parser_read('y inhomogeneity',ydir,0)
+
+ call parser_read('Postprocessing',ipost,0)
+
+ call parser_read('Forcing',iforce,0)
+ if (iforce.eq.1) call forcing_init
+
+ call parser_read('Courant number', courant,0.5_WP)
+
+!!!! Determine if it is required to solver the scalar equation
+!!!! If running from scratch with forcing, dont solver scalar equation
+
+ call parser_read('Simulation type', itype)
+ call parser_read('Compute scalar', iscalar)
+ if (iscalar.eq.0) then
+ if (rank.eq.0) print *,'Not solving scalar transport equation .....'
+ endif
+
+ call parser_read('Imposing mean gradient',impose,0)
+ if (impose.eq.1) then
+ call parser_read('X-gradient',cx,0.0_WP)
+ call parser_read('Y-gradient',cy,0.0_WP)
+ call parser_read('Z-gradient',cz,0.0_WP)
+ else
+ cx = 0.0_WP
+ cy = 0.0_WP
+ cz = 0.0_WP
+ endif
+
+ spfilename = 'spectrum_solver.init'
+ spfilename2 = 'spectrum_solver.init.z'
+ call get_dns_numbers(0)
+
+ print*,'test U init solver', U(1,1,1), V(1,1,1),W(1,1,1)
+
+end subroutine solver_init
+
+
+
+subroutine solver_step
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ complex(WP), dimension(:,:,:), allocatable :: Pressk
+ real(WP), dimension(:,:,:), allocatable :: tab
+ character(len=str_long) :: sim_name
+ real(WP) :: Ufz, Vfz, Wfz, xx
+
+ integer :: i,j,k,ierr
+
+ real(WP) :: kk,h, divumax
+
+
+ allocate(Pressk(fns1,fns2,fns3))
+ allocate(tab(ns1,ns2,ns3))
+
+
+!!$ if (rank.eq.0) print *,' Viscosity', mu_solver
+!!!! GEL DU CHAMP DE VITESSE POUR LES TEST !!!!
+call parser_read('Simulation name', sim_name)
+if (trim(sim_name).eq.'Test case') then
+ call parser_read('Frozen U', Ufz)
+ call parser_read('Frozen V', Vfz)
+ call parser_read('Frozen W', Wfz)
+ do i = 1, nx
+ xx = float(i-1)*L/nx
+ U(i,:,:) = Ufz + 0.5*sin(xx)
+ end do
+ V = Vfz
+ W = Wfz
+ print*,'1. U,V,W',U(1,1,1),V(1,1,1),W(1,1,1) !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+endif
+
+ call get_timestep
+ sim_time = sim_time +dt
+
+!!!!!!!!!!!!
+!!! Second-order RK scheme
+!!!!!!!!!!!
+ h = dt/2.0_WP
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ Udummy(i,j,k) = Uk(i,j,k)
+ Vdummy(i,j,k) = Vk(i,j,k)
+ Wdummy(i,j,k) = Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call non_linear
+
+! if (iforce.eq.1) call force_compute
+!!!!!! Step 1 for RK scheme
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Uk(i,j,k) + h*nlx(i,j,k))/exp(mu_solver*kk*h)
+ Vk(i,j,k) = (Vk(i,j,k) + h*nly(i,j,k))/exp(mu_solver*kk*h)
+ Wk(i,j,k) = (Wk(i,j,k) + h*nlz(i,j,k))/exp(mu_solver*kk*h)
+ enddo
+ enddo
+ enddo
+
+
+!!$
+!!$!!!!!!! Step 2 for RK scheme
+!!$
+ call non_linear
+ if (iforce.eq.1) call force_compute
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Udummy(i,j,k) + dt*nlx(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Vk(i,j,k) = (Vdummy(i,j,k) + dt*nly(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Wk(i,j,k) = (Wdummy(i,j,k) + dt*nlz(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ enddo
+ enddo
+ enddo
+
+ ! Projection
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ if(kk.gt.0.0_WP) then
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )/kk
+ end if
+ Uk(i,j,k) = Uk(i,j,k) - ii*kx(i)*Pressk(i,j,k)
+ Vk(i,j,k) = Vk(i,j,k) - ii*ky(j)*Pressk(i,j,k)
+ Wk(i,j,k) = Wk(i,j,k) - ii*kz(k)*Pressk(i,j,k)
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )
+ end do
+ end do
+ end do
+! call btran_wrap(Pressk,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+! call parallel_max(maxval(abs(tab)),divumax)
+! if (rank.eq.0) print*,'divergence max = ', divumax
+! call parallel_max(maxval(abs(Uk)),divumax)
+! if (rank.eq.0) print*,'abs(Uk) max = ', divumax
+
+!!PAR!! - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+ call ftran_wrap(SC,Zk,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ Zk = Zk/real(nxsc**3.0,WP)
+ if (iscalar.ne.0) then
+ do k = 1,fns3sc
+ do j = 1,fns2sc
+ do i = 1,fns1sc
+ kk = kxsc(i)**2.0 + kysc(j)**2.0 + kzsc(k)**2.0
+ Zk(i,j,k) = Zk(i,j,k)/exp(diff_solver*kk*dt)
+ enddo
+ enddo
+ enddo
+ end if
+ call btran_wrap(Zk,SC,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+ if (nproc.ne.1) then
+ if (rank.eq.0) print*,'NOT AVAILABLE IN PARALLEL'
+ STOP
+ else
+
+!!PAR!! 1. on remet les vitesses dans l'espace physique
+ if (trim(sim_name).eq.'Test case') then
+ call parser_read('Frozen U', Ufz)
+ call parser_read('Frozen V', Vfz)
+ call parser_read('Frozen W', Wfz)
+ do i = 1, nx
+ xx = float(i-1)*L/nx
+ U(i,:,:) = Ufz+0.5*sin(xx)
+ end do
+ V = Vfz
+ W = Wfz
+ print*,'1b. U,V,W',U(1,1,1),V(1,1,1),W(1,1,1) !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+ endif
+ if (trim(sim_name).ne.'Test case') call u_compute !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+ if (trim(sim_name).eq.'Test case') print*,'2. U,V,W',U(1,1,1),V(1,1,1),W(1,1,1) !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+
+!!PAR!! 2. appelle du transport particulaire
+ call x_advec
+ call y_advec
+ call z_advec
+
+ end if
+!!PAR!! - FIN - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+
+
+ deallocate(Pressk)
+ deallocate(tab)
+
+
+end subroutine solver_step
+
+subroutine non_linear
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(:,:,:),allocatable :: ddx,ddy,ddz,nis
+ real(WP), dimension(:,:,:),allocatable :: us,vs,ws
+ real(WP), dimension(:,:,:),allocatable :: uss,vss,wss
+ complex(WP), dimension(:,:,:),allocatable :: ddxk,ddyk,ddzk
+ ! LES
+
+ complex(WP) :: knl
+ real(WP) :: kk
+
+ integer :: i,j,k
+ real(WP) :: umax,vmax,wmax
+
+ integer :: sizemess, tag, ierr, status(MPI_STATUS_SIZE)
+ integer :: yeloc, ysloc, yelocsc, yslocsc, rank2send1, rank2send2, fs1, fe1, fs2, fe2, fnysrank, fnyerank, cptrank
+
+
+
+ allocate(ddx(ns1,ns2,ns3))
+ allocate(ddy(ns1,ns2,ns3))
+ allocate(ddz(ns1,ns2,ns3))
+ allocate(nis(ns1,ns2,ns3))
+
+ allocate(ddxk(fns1,fns2,fns3))
+ allocate(ddyk(fns1,fns2,fns3))
+ allocate(ddzk(fns1,fns2,fns3))
+
+
+ allocate(us(ns1,ns2,ns3))
+ allocate(vs(ns1,ns2,ns3))
+ allocate(ws(ns1,ns2,ns3))
+
+!!!!!!!!!!!
+!! Convert velocity to spatial coordinates
+!!!!!!!!!!
+
+ call btran_wrap(Uk,us,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,vs,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,ws,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ call parallel_max(maxval(abs(us)),umax)
+!!$ call parallel_max(maxval(abs(vs)),vmax)
+!!$ call parallel_max(maxval(abs(ws)),wmax)
+!!$
+!!$! if (rank.eq.0) write(*,'(A10,3(E12.5,3X))') ' MAX VAL', umax,vmax,wmax
+
+
+!!$ if (rank.eq.0) print *,' After velocity conversion'
+
+
+!!!!!!!!!!
+!! Form the first term in the skew-symmetric form
+!!!!!!!!!
+
+
+!!!! U component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*us(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*us(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*us(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2x(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! V component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*vs(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*vs(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*vs(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2y(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! W component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*ws(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*ws(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*ws(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2z(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! Compute the second term in the skew symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Uk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Uk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Uk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After btran in U computations'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product evaluations'
+
+ call ftran_wrap(nis,nlx,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After forward transforms'
+
+ nlx = nlx/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlx computation'
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Vk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Vk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Vk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After b trans in V compute'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product eval. in V'
+
+ call ftran_wrap(nis,nly,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After forward trans in V'
+
+ nly = nly/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nly computation'
+
+!!!!!!!!!!!!!!
+!! Compute W products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Wk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Wk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(nis,nlz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ nlz = nlz/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlz computation'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Form the complex skew-symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlx(i,j,k) = 0.5*(nlx(i,j,k) + nlu2x(i,j,k))
+ nly(i,j,k) = 0.5*(nly(i,j,k) + nlu2y(i,j,k))
+ nlz(i,j,k) = 0.5*(nlz(i,j,k) + nlu2z(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! Form non-linear term for the scalar
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ deallocate(ddx)
+ deallocate(ddy)
+ deallocate(ddz)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(nis)
+
+
+!!PAR!! if (iscalar.eq.0) then
+
+ deallocate(us)
+ deallocate(vs)
+ deallocate(ws)
+!!PAR!! nlmf = 0.0_WP
+
+!!PAR!! else
+
+!!PAR!! allocate(ddx(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddy(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddz(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(nis(ns1sc,ns2sc,ns3sc))
+
+!!PAR!! allocate(ddxk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddyk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddzk(fns1sc,fns2sc,fns3sc))
+
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! ddxk(i,j,k) = ii*kxsc(i)*Zk(i,j,k)
+!!PAR!! ddyk(i,j,k) = ii*kysc(j)*Zk(i,j,k)
+!!PAR!! ddzk(i,j,k) = ii*kzsc(k)*Zk(i,j,k)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+!!PAR!! ddx = 0.0_WP
+!!PAR!! ddy = 0.0_WP
+!!PAR!! ddz = 0.0_WP
+
+!!PAR!! call btran_wrap(ddxk,ddx,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddyk,ddy,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddzk,ddz,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+!!PAR!! deallocate(ddxk)
+!!PAR!! deallocate(ddyk)
+!!PAR!! deallocate(ddzk)
+
+!!PAR!! allocate(uss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(vss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(wss(ns1sc,ns2sc,ns3sc))
+!!PAR!! uss = 0.0
+!!PAR!! vss = 0.0
+!!PAR!! wss = 0.0
+
+!!PAR!! if (ns1sc.gt.ns1) then
+!!PAR!! call discretisation2(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else if (ns1sc.lt.ns1) then
+!!PAR!! call discretisation3(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else
+!!PAR!! uss = us
+!!PAR!! vss = vs
+!!PAR!! wss = ws
+!!PAR!! end if
+
+!!PAR!! deallocate(us)
+!!PAR!! deallocate(vs)
+!!PAR!! deallocate(ws)
+
+!!PAR!! do k = 1,ns3sc
+!!PAR!! do j = 1,ns2sc
+!!PAR!! do i = 1,ns1sc
+!!PAR!! nis(i,j,k) = uss(i,j,k)*(ddx(i,j,k)+cx) + &
+!!PAR!! & vss(i,j,k)*(ddy(i,j,k)+cy) +&
+!!PAR!! & wss(i,j,k)*(ddz(i,j,k)+cz)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! deallocate(uss)
+!!PAR!! deallocate(vss)
+!!PAR!! deallocate(wss)
+!!PAR!! deallocate(ddx)
+!!PAR!! deallocate(ddy)
+!!PAR!! deallocate(ddz)
+
+!!PAR!! call ftran_wrap(nis,nlmf,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! nlmf = nlmf/real((ns1sc**3.0),WP)
+
+!!PAR!! deallocate(nis)
+
+
+!!PAR!! endif
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Dealias the non-linear term
+
+ call dealias
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! LES MODEL
+
+if (iles.ne.0) then
+! if (iles.eq.1) call smagmodel
+ if (iles.eq.2) call dynsmagmodel
+! if (iles.eq.8) call SISM
+! if (iles.eq.12) call dynsmagmodel2
+! if (iles.eq.13) call dynsmagmodel3
+endif
+if (ilessc.ne.0) then
+! if (ilessc.eq.1) call smagmodelsca
+! if (ilessc.eq.2) call dynsmagmodelsca
+! if (ilessc.eq.3) call dynsmagmodelscanew
+! if (ilessc.eq.4) call dynsmagmodelscacut
+! if (ilessc.eq.5) call dynsmagmodelscanewcut
+! if (ilessc.eq.6) call dynsfmodelscacut
+! if (ilessc.eq.7) call dynsfmodelscanewcut
+! if (ilessc.eq.8) call dynsigmamodelscacut
+! if (ilessc.eq.9) call dynsigmamodelscanewcut
+! if (ilessc.eq.12) call dyndd2modelscacut
+! if (ilessc.eq.13) call dyndd4modelscacut
+! if (ilessc.eq.14) call dynddsmagmodelscanewcut
+! if (ilessc.eq.15) call dynsflpmodelscacut
+! if (ilessc.eq.16) call ssmodelscacut
+! if (ilessc.eq.17) call dynsmagtestmodelscacut
+endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!!!!!!!
+!! Form the pressure term and add it to the nonlinear term
+!!!!!!!!!!
+
+!! SEMBLE NE PAS DONNER DIV(U)=0. ???
+!!
+!! do k = 1,fns3
+!! do j = 1,fns2
+!! do i = 1,fns1
+!!
+!! kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+!! if (sqrt(kk).gt.kmin) then
+!! knl = kx(i)*nlx(i,j,k) + ky(j)*nly(i,j,k) +&
+!! & kz(k)*nlz(i,j,k)
+!! nlx(i,j,k) = kx(i)*knl/kk - nlx(i,j,k)
+!! nly(i,j,k) = ky(j)*knl/kk - nly(i,j,k)
+!! nlz(i,j,k) = kz(k)*knl/kk - nlz(i,j,k)
+!! nlmf(i,j,k) = -nlmf(i,j,k)
+!! else
+!! nlx(i,j,k) = 0.0_WP
+!! nly(i,j,k) = 0.0_WP
+!! nlz(i,j,k) = 0.0_WP
+!! nlmf(i,j,k) = 0.0_WP
+!!!!!!!!!!!!!!!INSTEAD
+ nlx = -nlx
+ nly = -nly
+ nlz = -nlz
+!!PAR!! nlmf = -nlmf
+!! endif
+!! enddo
+!! enddo
+!! enddo
+
+
+end subroutine non_linear
+
+
+subroutine get_timestep
+
+ use solver
+ use parallel
+ use data
+
+ real(WP) :: max_s, max_sg
+ character(len=str_long) :: sim_name
+
+ integer :: ierr,nn
+
+ max_s = 0.0_WP
+ max_sg = 0.0_WP
+
+ call parser_read('Simulation name', sim_name)
+ if (trim(sim_name).ne.'Test case') call u_compute !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+
+ max_s = maxval(abs(U) +abs(V)+abs(W))
+
+
+ call MPI_ALLREDUCE(max_s,max_sg,1,MPI_REAL_WP,MPI_MAX,&
+ &MPI_COMM_WORLD,ierr)
+
+ call parser_read('fixed time step',dt)
+
+ if (dt.eq.0) then
+ if (max_sg.gt.0.0_WP) then
+ nn = nx
+!!PAR!! if(iscalar.ne.0) nn = max(nx,nxsc)
+ dt = courant/max_sg*(L/nn)
+ else
+ print *,' SOMETHING WRONG IN TIME_STEP', rank, max_sg,max_s,nx
+ stop
+ endif
+ endif
+
+
+!!$ print *,' MAX_TIME ', dt
+
+end subroutine get_timestep
+
+
+subroutine dealias
+
+ use solver
+ use parallel
+ use precision
+
+ implicit none
+
+ real(WP) :: kk
+ integer :: i,j,k
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+
+ kk = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+ ! kk = sqrt(kk)
+! if ((abs(kz(k)).gt.kmax).or.(abs(ky(j)).gt.kmax).or.(abs(kx(i)).gt.kmax)) then
+! if (kk.gt.kmax) then
+ if (kk.gt.kcut) then
+ nlx(i,j,k) = 0.0_WP
+ nly(i,j,k) = 0.0_WP
+ nlz(i,j,k) = 0.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = sqrt(kxsc(i)**2.0_WP + kysc(j)**2.0_WP + kzsc(k)**2.0_WP)
+!!PAR!! if (kk.gt.kcutsc) then
+!!PAR!! nlmf(i,j,k) = 0.0_WP
+!!PAR!! endif
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+end subroutine dealias
+
+subroutine fourier_write
+ use solver
+
+! call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+end subroutine fourier_write
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav b/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav
new file mode 100755
index 0000000000000000000000000000000000000000..f910ac3f420709c68c81c5e7387769d02e91563c
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav
@@ -0,0 +1,963 @@
+module solver
+
+ use precision
+
+ implicit none
+
+ real(WP), dimension(:), allocatable :: kx
+ real(WP), dimension(:), allocatable :: ky
+ real(WP), dimension(:), allocatable :: kz
+
+ real(WP), dimension(:), allocatable :: kxsc
+ real(WP), dimension(:), allocatable :: kysc
+ real(WP), dimension(:), allocatable :: kzsc
+
+ integer :: deal
+ real(WP) :: dk,kmax,kcut
+ real(WP) :: kmaxsc,kcutsc
+
+ real(WP) :: mu_solver, diff_solver
+ real(WP) :: courant
+
+ integer :: iforce,iscalar,iles,ilessc,ydir,ipost
+
+
+ complex(WP), dimension(:,:,:), allocatable :: Uk
+ complex(WP), dimension(:,:,:), allocatable :: Vk
+ complex(WP), dimension(:,:,:), allocatable :: Wk
+ complex(WP), dimension(:,:,:), allocatable :: Zk
+
+ complex(WP), dimension(:,:,:),pointer :: Udummy
+ complex(WP), dimension(:,:,:),pointer :: Vdummy
+ complex(WP), dimension(:,:,:),pointer :: Wdummy
+ complex(WP), dimension(:,:,:),pointer :: Zdummy
+
+ complex(WP), dimension(:,:,:), allocatable :: nlx
+ complex(WP), dimension(:,:,:), allocatable :: nly
+ complex(WP), dimension(:,:,:), allocatable :: nlz
+ complex(WP), dimension(:,:,:), allocatable :: nlmf
+
+ complex(WP), dimension(:,:,:), allocatable :: nlu2x
+ complex(WP), dimension(:,:,:), allocatable :: nlu2y
+ complex(WP), dimension(:,:,:), allocatable :: nlu2z
+
+
+
+ logical, parameter :: flg_inplace = .false.
+ complex(WP), parameter :: ii = (0.0_WP,1.0_WP)
+ real(WP), parameter :: kmin = 1e-06_WP
+
+ real(WP) :: dt,sim_time
+
+ integer :: impose
+ real(WP) :: cx,cy,cz
+
+end module solver
+
+
+subroutine solver_init
+
+ use parallel
+ use data
+ use solver
+ use transform
+
+ implicit none
+
+ integer :: i,j,k,il,jl,kl,gg(3),itype
+ real(WP) :: pi
+ real(WP) :: umax,vmax,wmax
+
+
+ allocate(kx(fns1))
+ allocate(ky(fns2))
+ allocate(kz(fns3))
+
+!!PAR!! allocate(kxsc(fns1sc))
+!!PAR!! allocate(kysc(fns2sc))
+!!PAR!! allocate(kzsc(fns3sc))
+
+ pi = acos(-1.0_WP)
+ dk = 2.0_WP*pi/L
+
+ do i = fnxs,fnxe
+ il = i -fnxs+1
+ kx(il) = real((i-1),WP)*dk
+ enddo
+!!PAR!! do i = fnxssc,fnxesc
+!!PAR!! il = i -fnxssc+1
+!!PAR!! kxsc(il) = real((i-1),WP)*dk
+!!PAR!! enddo
+
+ do j = fnys,fnye
+ jl = j - fnys +1
+ ky(jl) = real((j-1),WP)*dk
+ if (j.gt.nk) ky(jl) = -real(nx+1-j,WP)*dk
+ enddo
+!!PAR!! do j = fnyssc,fnyesc
+!!PAR!! jl = j - fnyssc +1
+!!PAR!! kysc(jl) = real((j-1),WP)*dk
+!!PAR!! if (j.gt.nksc) kysc(jl) = -real(nxsc+1-j,WP)*dk
+!!PAR!! enddo
+
+ do k = fnzs,fnze
+ kl = k -fnzs+1
+ kz(kl) = real((k-1),WP)*dk
+ if (k.gt.nk) kz(kl) = -real(nx+1-k,WP)*dk
+ enddo
+!!PAR!! do k = fnzssc,fnzesc
+!!PAR!! kl = k -fnzssc+1
+!!PAR!! kzsc(kl) = real((k-1),WP)*dk
+!!PAR!! if (k.gt.nksc) kzsc(kl) = -real(nxsc+1-k,WP)*dk
+!!PAR!! enddo
+
+
+! print *,'First checkpoint',rank
+
+
+ allocate(Uk(fns1,fns2,fns3))
+ allocate(Vk(fns1,fns2,fns3))
+ allocate(Wk(fns1,fns2,fns3))
+!!PAR!! allocate(Zk(fns1sc,fns2sc,fns3sc))
+
+ allocate(Udummy(fns1,fns2,fns3))
+ allocate(Vdummy(fns1,fns2,fns3))
+ allocate(Wdummy(fns1,fns2,fns3))
+!!PAR!! allocate(Zdummy(fns1sc,fns2sc,fns3sc))
+
+
+
+ call ftran_wrap(U,Uk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(V,Vk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(W,Wk,ns1,ns2,ns3,fns1,fns2,fns3)
+!!PAR!! call ftran_wrap(SC,Zk,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+
+ Uk = Uk/real(nx**3.0,WP)
+ Vk = Vk/real(nx**3.0,WP)
+ Wk = Wk/real(nx**3.0,WP)
+!!PAR!! Zk = Zk/real(nxsc**3.0,WP)
+
+ call parallel_max(maxval(abs(Uk)),umax)
+ call parallel_max(maxval(abs(Vk)),vmax)
+ call parallel_max(maxval(abs(Wk)),wmax)
+
+ if (rank.eq.0) then
+ print *,' Maximum of U,V,W after trans',umax,vmax,wmax
+ endif
+
+
+
+!!$ call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+ allocate(nlx(fns1,fns2,fns3))
+ allocate(nly(fns1,fns2,fns3))
+ allocate(nlz(fns1,fns2,fns3))
+!!PAR!! allocate(nlmf(fns1sc,fns2sc,fns3sc))
+ allocate(nlu2x(fns1,fns2,fns3))
+ allocate(nlu2y(fns1,fns2,fns3))
+ allocate(nlu2z(fns1,fns2,fns3))
+
+!!$
+!!$ call parallel_max(maxval(abs(Uk)),umax)
+!!$ call parallel_max(maxval(abs(Vk)),vmax)
+!!$ call parallel_max(maxval(abs(Wk)),wmax)
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Maximum U,V,W in solver',umax,vmax,wmax
+!!$ endif
+!!$
+!!$ if (umax.eq.maxval(abs(Uk))) then
+!!$ print *,' Maximum in rank', rank
+!!$ print *,' location ', maxloc(abs(Uk))
+!!$ gg = maxloc(abs(Uk))
+!!$ print *,' max value for conformation', Uk(gg(1),gg(2),gg(3))
+!!$ endif
+!!$
+!!$ if (wmax.eq.maxval(abs(Wk))) then
+!!$ print *,' Maximum in rank W', rank
+!!$ print *,' location W', maxloc(abs(Wk))
+!!$ gg = maxloc(abs(Wk))
+!!$ print *,' max value for W conformation', Wk(gg(1),gg(2),gg(3))
+!!$ endif
+
+ sim_time = 0.0_WP
+
+ call parser_read('Dealiasing',deal,0)
+
+ kmax = sqrt(3.0_WP)*kx(nx/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+!!PAR!! kmaxsc = sqrt(3.0_WP)*kxsc(nxsc/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+ if (deal.eq.1) then
+ kcut = 2.0_WP/3.0_WP*kmax
+!!PAR!! kcutsc = 2.0_WP/3.0_WP*kmaxsc
+ else
+ kcut = 10000.0_WP
+!!PAR!! kcutsc = 10000.0_WP
+ endif
+
+ mu_solver = mu
+ diff_solver = diff
+
+ call parser_read('LES model',iles,0)
+ call parser_read('LES scalar model',ilessc,0)
+ call parser_read('y inhomogeneity',ydir,0)
+
+ call parser_read('Postprocessing',ipost,0)
+
+ call parser_read('Forcing',iforce,0)
+ if (iforce.eq.1) call forcing_init
+
+ call parser_read('Courant number', courant,0.5_WP)
+
+!!!! Determine if it is required to solver the scalar equation
+!!!! If running from scratch with forcing, dont solver scalar equation
+
+ call parser_read('Simulation type', itype)
+ call parser_read('Compute scalar', iscalar)
+ if (iscalar.eq.0) then
+ if (rank.eq.0) print *,'Not solving scalar transport equation .....'
+ endif
+
+ call parser_read('Imposing mean gradient',impose,0)
+ if (impose.eq.1) then
+ call parser_read('X-gradient',cx,0.0_WP)
+ call parser_read('Y-gradient',cy,0.0_WP)
+ call parser_read('Z-gradient',cz,0.0_WP)
+ else
+ cx = 0.0_WP
+ cy = 0.0_WP
+ cz = 0.0_WP
+ endif
+
+ spfilename = 'spectrum_solver.init'
+ spfilename2 = 'spectrum_solver.init.z'
+ call get_dns_numbers(0)
+
+ print*,'test U init solver', U(1,1,1), V(1,1,1),W(1,1,1)
+
+end subroutine solver_init
+
+
+
+subroutine solver_step
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ complex(WP), dimension(:,:,:), allocatable :: Pressk
+ real(WP), dimension(:,:,:), allocatable :: tab
+ character(len=str_long) :: sim_name
+ real(WP) :: Ufz, Vfz, Wfz
+
+ integer :: i,j,k,ierr
+
+ real(WP) :: kk,h, divumax
+
+
+ allocate(Pressk(fns1,fns2,fns3))
+ allocate(tab(ns1,ns2,ns3))
+
+
+!!$ if (rank.eq.0) print *,' Viscosity', mu_solver
+!!!! GEL DU CHAMP DE VITESSE POUR LES TEST !!!!
+call parser_read('Simulation name', sim_name)
+if (trim(sim_name).eq.'Test case') then
+ call parser_read('Frozen U', Ufz)
+ call parser_read('Frozen V', Vfz)
+ call parser_read('Frozen W', Wfz)
+ U = Ufz
+ V = Vfz
+ W = Wfz
+endif
+
+ call get_timestep
+ sim_time = sim_time +dt
+
+!!!!!!!!!!!!
+!!! Second-order RK scheme
+!!!!!!!!!!!
+ h = dt/2.0_WP
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ Udummy(i,j,k) = Uk(i,j,k)
+ Vdummy(i,j,k) = Vk(i,j,k)
+ Wdummy(i,j,k) = Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! Zdummy(i,j,k) = Zk(i,j,k)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+ call non_linear
+
+! if (iforce.eq.1) call force_compute
+!!!!!! Step 1 for RK scheme
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Uk(i,j,k) + h*nlx(i,j,k))/exp(mu_solver*kk*h)
+ Vk(i,j,k) = (Vk(i,j,k) + h*nly(i,j,k))/exp(mu_solver*kk*h)
+ Wk(i,j,k) = (Wk(i,j,k) + h*nlz(i,j,k))/exp(mu_solver*kk*h)
+ enddo
+ enddo
+ enddo
+!!PAR!! if (iscalar.ne.0) then
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = kxsc(i)**2.0 + kysc(j)**2.0 + kzsc(k)**2.0
+!!PAR!! Zk(i,j,k) = (Zk(i,j,k) + h*nlmf(i,j,k))/exp(diff_solver*kk*h)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! end if
+
+
+!!$
+!!$!!!!!!! Step 2 for RK scheme
+!!$
+ call non_linear
+ if (iforce.eq.1) call force_compute
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Udummy(i,j,k) + dt*nlx(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Vk(i,j,k) = (Vdummy(i,j,k) + dt*nly(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Wk(i,j,k) = (Wdummy(i,j,k) + dt*nlz(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ enddo
+ enddo
+ enddo
+!!PAR!! if (iscalar.ne.0) then
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = kxsc(i)**2.0 + kysc(j)**2.0 + kzsc(k)**2.0
+!!PAR!! Zk(i,j,k) = (Zdummy(i,j,k) + dt*nlmf(i,j,k)*exp(diff_solver*kk*h))/exp(diff_solver*kk*dt)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! end if
+
+ ! Projection
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ if(kk.gt.0.0_WP) then
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )/kk
+ end if
+ Uk(i,j,k) = Uk(i,j,k) - ii*kx(i)*Pressk(i,j,k)
+ Vk(i,j,k) = Vk(i,j,k) - ii*ky(j)*Pressk(i,j,k)
+ Wk(i,j,k) = Wk(i,j,k) - ii*kz(k)*Pressk(i,j,k)
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )
+ end do
+ end do
+ end do
+! call btran_wrap(Pressk,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+! call parallel_max(maxval(abs(tab)),divumax)
+! if (rank.eq.0) print*,'divergence max = ', divumax
+! call parallel_max(maxval(abs(Uk)),divumax)
+! if (rank.eq.0) print*,'abs(Uk) max = ', divumax
+
+!!PAR!! - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+ if (nproc.ne.1) then
+ if (rank.eq.0) print*,'NOT AVAILABLE IN PARALLEL'
+ STOP
+ else
+
+!!PAR!! 1. on remet les vitesses dans l'espace physique
+ if (trim(sim_name).ne.'Test case') call u_compute !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+
+!!PAR!! 2. appelle du transport particulaire
+ call x_advec
+ call y_advec
+ call z_advec
+
+ end if
+!!PAR!! - FIN - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+
+
+ deallocate(Pressk)
+ deallocate(tab)
+
+
+end subroutine solver_step
+
+subroutine non_linear
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(:,:,:),allocatable :: ddx,ddy,ddz,nis
+ real(WP), dimension(:,:,:),allocatable :: us,vs,ws
+ real(WP), dimension(:,:,:),allocatable :: uss,vss,wss
+ complex(WP), dimension(:,:,:),allocatable :: ddxk,ddyk,ddzk
+ ! LES
+
+ complex(WP) :: knl
+ real(WP) :: kk
+
+ integer :: i,j,k
+ real(WP) :: umax,vmax,wmax
+
+ integer :: sizemess, tag, ierr, status(MPI_STATUS_SIZE)
+ integer :: yeloc, ysloc, yelocsc, yslocsc, rank2send1, rank2send2, fs1, fe1, fs2, fe2, fnysrank, fnyerank, cptrank
+
+
+
+ allocate(ddx(ns1,ns2,ns3))
+ allocate(ddy(ns1,ns2,ns3))
+ allocate(ddz(ns1,ns2,ns3))
+ allocate(nis(ns1,ns2,ns3))
+
+ allocate(ddxk(fns1,fns2,fns3))
+ allocate(ddyk(fns1,fns2,fns3))
+ allocate(ddzk(fns1,fns2,fns3))
+
+
+ allocate(us(ns1,ns2,ns3))
+ allocate(vs(ns1,ns2,ns3))
+ allocate(ws(ns1,ns2,ns3))
+
+!!!!!!!!!!!
+!! Convert velocity to spatial coordinates
+!!!!!!!!!!
+
+ call btran_wrap(Uk,us,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,vs,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,ws,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ call parallel_max(maxval(abs(us)),umax)
+!!$ call parallel_max(maxval(abs(vs)),vmax)
+!!$ call parallel_max(maxval(abs(ws)),wmax)
+!!$
+!!$! if (rank.eq.0) write(*,'(A10,3(E12.5,3X))') ' MAX VAL', umax,vmax,wmax
+
+
+!!$ if (rank.eq.0) print *,' After velocity conversion'
+
+
+!!!!!!!!!!
+!! Form the first term in the skew-symmetric form
+!!!!!!!!!
+
+
+!!!! U component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*us(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*us(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*us(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2x(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! V component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*vs(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*vs(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*vs(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2y(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! W component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*ws(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*ws(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*ws(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2z(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! Compute the second term in the skew symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Uk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Uk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Uk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After btran in U computations'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product evaluations'
+
+ call ftran_wrap(nis,nlx,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After forward transforms'
+
+ nlx = nlx/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlx computation'
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Vk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Vk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Vk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After b trans in V compute'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product eval. in V'
+
+ call ftran_wrap(nis,nly,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After nly computation'
+
+!!!!!!!!!!!!!!
+!! Compute W products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Wk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Wk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(nis,nlz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ nlz = nlz/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlz computation'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Form the complex skew-symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlx(i,j,k) = 0.5*(nlx(i,j,k) + nlu2x(i,j,k))
+ nly(i,j,k) = 0.5*(nly(i,j,k) + nlu2y(i,j,k))
+ nlz(i,j,k) = 0.5*(nlz(i,j,k) + nlu2z(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! Form non-linear term for the scalar
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ deallocate(ddx)
+ deallocate(ddy)
+ deallocate(ddz)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(nis)
+
+
+!!PAR!! if (iscalar.eq.0) then
+
+ deallocate(us)
+ deallocate(vs)
+ deallocate(ws)
+!!PAR!! nlmf = 0.0_WP
+
+!!PAR!! else
+
+!!PAR!! allocate(ddx(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddy(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddz(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(nis(ns1sc,ns2sc,ns3sc))
+
+!!PAR!! allocate(ddxk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddyk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddzk(fns1sc,fns2sc,fns3sc))
+
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! ddxk(i,j,k) = ii*kxsc(i)*Zk(i,j,k)
+!!PAR!! ddyk(i,j,k) = ii*kysc(j)*Zk(i,j,k)
+!!PAR!! ddzk(i,j,k) = ii*kzsc(k)*Zk(i,j,k)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+!!PAR!! ddx = 0.0_WP
+!!PAR!! ddy = 0.0_WP
+!!PAR!! ddz = 0.0_WP
+
+!!PAR!! call btran_wrap(ddxk,ddx,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddyk,ddy,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddzk,ddz,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+!!PAR!! deallocate(ddxk)
+!!PAR!! deallocate(ddyk)
+!!PAR!! deallocate(ddzk)
+
+!!PAR!! allocate(uss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(vss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(wss(ns1sc,ns2sc,ns3sc))
+!!PAR!! uss = 0.0
+!!PAR!! vss = 0.0
+!!PAR!! wss = 0.0
+
+!!PAR!! if (ns1sc.gt.ns1) then
+!!PAR!! call discretisation2(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else if (ns1sc.lt.ns1) then
+!!PAR!! call discretisation3(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else
+!!PAR!! uss = us
+!!PAR!! vss = vs
+!!PAR!! wss = ws
+!!PAR!! end if
+
+!!PAR!! deallocate(us)
+!!PAR!! deallocate(vs)
+!!PAR!! deallocate(ws)
+
+!!PAR!! do k = 1,ns3sc
+!!PAR!! do j = 1,ns2sc
+!!PAR!! do i = 1,ns1sc
+!!PAR!! nis(i,j,k) = uss(i,j,k)*(ddx(i,j,k)+cx) + &
+!!PAR!! & vss(i,j,k)*(ddy(i,j,k)+cy) +&
+!!PAR!! & wss(i,j,k)*(ddz(i,j,k)+cz)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! deallocate(uss)
+!!PAR!! deallocate(vss)
+!!PAR!! deallocate(wss)
+!!PAR!! deallocate(ddx)
+!!PAR!! deallocate(ddy)
+!!PAR!! deallocate(ddz)
+
+!!PAR!! call ftran_wrap(nis,nlmf,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! nlmf = nlmf/real((ns1sc**3.0),WP)
+
+!!PAR!! deallocate(nis)
+
+
+!!PAR!! endif
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Dealias the non-linear term
+
+ call dealias
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! LES MODEL
+
+if (iles.ne.0) then
+! if (iles.eq.1) call smagmodel
+ if (iles.eq.2) call dynsmagmodel
+! if (iles.eq.8) call SISM
+! if (iles.eq.12) call dynsmagmodel2
+! if (iles.eq.13) call dynsmagmodel3
+endif
+if (ilessc.ne.0) then
+! if (ilessc.eq.1) call smagmodelsca
+! if (ilessc.eq.2) call dynsmagmodelsca
+! if (ilessc.eq.3) call dynsmagmodelscanew
+! if (ilessc.eq.4) call dynsmagmodelscacut
+! if (ilessc.eq.5) call dynsmagmodelscanewcut
+! if (ilessc.eq.6) call dynsfmodelscacut
+! if (ilessc.eq.7) call dynsfmodelscanewcut
+! if (ilessc.eq.8) call dynsigmamodelscacut
+! if (ilessc.eq.9) call dynsigmamodelscanewcut
+! if (ilessc.eq.12) call dyndd2modelscacut
+! if (ilessc.eq.13) call dyndd4modelscacut
+! if (ilessc.eq.14) call dynddsmagmodelscanewcut
+! if (ilessc.eq.15) call dynsflpmodelscacut
+! if (ilessc.eq.16) call ssmodelscacut
+! if (ilessc.eq.17) call dynsmagtestmodelscacut
+endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!!!!!!!
+!! Form the pressure term and add it to the nonlinear term
+!!!!!!!!!!
+
+!! SEMBLE NE PAS DONNER DIV(U)=0. ???
+!!
+!! do k = 1,fns3
+!! do j = 1,fns2
+!! do i = 1,fns1
+!!
+!! kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+!! if (sqrt(kk).gt.kmin) then
+!! knl = kx(i)*nlx(i,j,k) + ky(j)*nly(i,j,k) +&
+!! & kz(k)*nlz(i,j,k)
+!! nlx(i,j,k) = kx(i)*knl/kk - nlx(i,j,k)
+!! nly(i,j,k) = ky(j)*knl/kk - nly(i,j,k)
+!! nlz(i,j,k) = kz(k)*knl/kk - nlz(i,j,k)
+!! nlmf(i,j,k) = -nlmf(i,j,k)
+!! else
+!! nlx(i,j,k) = 0.0_WP
+!! nly(i,j,k) = 0.0_WP
+!! nlz(i,j,k) = 0.0_WP
+!! nlmf(i,j,k) = 0.0_WP
+!!!!!!!!!!!!!!!INSTEAD
+ nlx = -nlx
+ nly = -nly
+ nlz = -nlz
+!!PAR!! nlmf = -nlmf
+!! endif
+!! enddo
+!! enddo
+!! enddo
+
+
+end subroutine non_linear
+
+
+subroutine get_timestep
+
+ use solver
+ use parallel
+ use data
+
+ real(WP) :: max_s, max_sg
+ character(len=str_long) :: sim_name
+
+ integer :: ierr,nn
+
+ max_s = 0.0_WP
+ max_sg = 0.0_WP
+
+ call parser_read('Simulation name', sim_name)
+ if (trim(sim_name).ne.'Test case') call u_compute !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+
+ max_s = maxval(abs(U) +abs(V)+abs(W))
+
+
+ call MPI_ALLREDUCE(max_s,max_sg,1,MPI_REAL_WP,MPI_MAX,&
+ &MPI_COMM_WORLD,ierr)
+
+ call parser_read('fixed time step',dt)
+
+ if (dt.eq.0) then
+ if (max_sg.gt.0.0_WP) then
+ nn = nx
+!!PAR!! if(iscalar.ne.0) nn = max(nx,nxsc)
+ dt = courant/max_sg*(L/nn)
+ else
+ print *,' SOMETHING WRONG IN TIME_STEP', rank, max_sg,max_s,nx
+ stop
+ endif
+ endif
+
+
+!!$ print *,' MAX_TIME ', dt
+
+end subroutine get_timestep
+
+
+subroutine dealias
+
+ use solver
+ use parallel
+ use precision
+
+ implicit none
+
+ real(WP) :: kk
+ integer :: i,j,k
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+
+ kk = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+ ! kk = sqrt(kk)
+! if ((abs(kz(k)).gt.kmax).or.(abs(ky(j)).gt.kmax).or.(abs(kx(i)).gt.kmax)) then
+! if (kk.gt.kmax) then
+ if (kk.gt.kcut) then
+ nlx(i,j,k) = 0.0_WP
+ nly(i,j,k) = 0.0_WP
+ nlz(i,j,k) = 0.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = sqrt(kxsc(i)**2.0_WP + kysc(j)**2.0_WP + kzsc(k)**2.0_WP)
+!!PAR!! if (kk.gt.kcutsc) then
+!!PAR!! nlmf(i,j,k) = 0.0_WP
+!!PAR!! endif
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+end subroutine dealias
+
+subroutine fourier_write
+ use solver
+
+! call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+end subroutine fourier_write
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav2 b/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav2
new file mode 100755
index 0000000000000000000000000000000000000000..e1a55aeb2d3414e6e92cbe0bdd9a148d7458844f
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/solver.f90_sav2
@@ -0,0 +1,987 @@
+module solver
+
+ use precision
+
+ implicit none
+
+ real(WP), dimension(:), allocatable :: kx
+ real(WP), dimension(:), allocatable :: ky
+ real(WP), dimension(:), allocatable :: kz
+
+ real(WP), dimension(:), allocatable :: kxsc
+ real(WP), dimension(:), allocatable :: kysc
+ real(WP), dimension(:), allocatable :: kzsc
+
+ integer :: deal
+ real(WP) :: dk,kmax,kcut
+ real(WP) :: kmaxsc,kcutsc
+
+ real(WP) :: mu_solver, diff_solver
+ real(WP) :: courant
+
+ integer :: iforce,iscalar,iles,ilessc,ydir,ipost
+
+
+ complex(WP), dimension(:,:,:), allocatable :: Uk
+ complex(WP), dimension(:,:,:), allocatable :: Vk
+ complex(WP), dimension(:,:,:), allocatable :: Wk
+ complex(WP), dimension(:,:,:), allocatable :: Zk
+
+ complex(WP), dimension(:,:,:),pointer :: Udummy
+ complex(WP), dimension(:,:,:),pointer :: Vdummy
+ complex(WP), dimension(:,:,:),pointer :: Wdummy
+ complex(WP), dimension(:,:,:),pointer :: Zdummy
+
+ complex(WP), dimension(:,:,:), allocatable :: nlx
+ complex(WP), dimension(:,:,:), allocatable :: nly
+ complex(WP), dimension(:,:,:), allocatable :: nlz
+ complex(WP), dimension(:,:,:), allocatable :: nlmf
+
+ complex(WP), dimension(:,:,:), allocatable :: nlu2x
+ complex(WP), dimension(:,:,:), allocatable :: nlu2y
+ complex(WP), dimension(:,:,:), allocatable :: nlu2z
+
+
+
+ logical, parameter :: flg_inplace = .false.
+ complex(WP), parameter :: ii = (0.0_WP,1.0_WP)
+ real(WP), parameter :: kmin = 1e-06_WP
+
+ real(WP) :: dt,sim_time
+
+ integer :: impose
+ real(WP) :: cx,cy,cz
+
+end module solver
+
+
+subroutine solver_init
+
+ use parallel
+ use data
+ use solver
+ use transform
+
+ implicit none
+
+ integer :: i,j,k,il,jl,kl,gg(3),itype
+ real(WP) :: pi
+ real(WP) :: umax,vmax,wmax
+
+ if (rank.eq.0) print*,'init : test1'
+
+ allocate(kx(fns1))
+ allocate(ky(fns2))
+ allocate(kz(fns3))
+
+!!PAR!! allocate(kxsc(fns1sc))
+!!PAR!! allocate(kysc(fns2sc))
+!!PAR!! allocate(kzsc(fns3sc))
+
+ pi = acos(-1.0_WP)
+ dk = 2.0_WP*pi/L
+
+ do i = fnxs,fnxe
+ il = i -fnxs+1
+ kx(il) = real((i-1),WP)*dk
+ enddo
+!!PAR!! do i = fnxssc,fnxesc
+!!PAR!! il = i -fnxssc+1
+!!PAR!! kxsc(il) = real((i-1),WP)*dk
+!!PAR!! enddo
+
+ do j = fnys,fnye
+ jl = j - fnys +1
+ ky(jl) = real((j-1),WP)*dk
+ if (j.gt.nk) ky(jl) = -real(nx+1-j,WP)*dk
+ enddo
+!!PAR!! do j = fnyssc,fnyesc
+!!PAR!! jl = j - fnyssc +1
+!!PAR!! kysc(jl) = real((j-1),WP)*dk
+!!PAR!! if (j.gt.nksc) kysc(jl) = -real(nxsc+1-j,WP)*dk
+!!PAR!! enddo
+
+ do k = fnzs,fnze
+ kl = k -fnzs+1
+ kz(kl) = real((k-1),WP)*dk
+ if (k.gt.nk) kz(kl) = -real(nx+1-k,WP)*dk
+ enddo
+!!PAR!! do k = fnzssc,fnzesc
+!!PAR!! kl = k -fnzssc+1
+!!PAR!! kzsc(kl) = real((k-1),WP)*dk
+!!PAR!! if (k.gt.nksc) kzsc(kl) = -real(nxsc+1-k,WP)*dk
+!!PAR!! enddo
+
+
+! print *,'First checkpoint',rank
+
+
+ allocate(Uk(fns1,fns2,fns3))
+ allocate(Vk(fns1,fns2,fns3))
+ allocate(Wk(fns1,fns2,fns3))
+!!PAR!! allocate(Zk(fns1sc,fns2sc,fns3sc))
+
+ allocate(Udummy(fns1,fns2,fns3))
+ allocate(Vdummy(fns1,fns2,fns3))
+ allocate(Wdummy(fns1,fns2,fns3))
+!!PAR!! allocate(Zdummy(fns1sc,fns2sc,fns3sc))
+
+
+ if (rank.eq.0) print*,'init : test2'
+
+ call ftran_wrap(U,Uk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(V,Vk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(W,Wk,ns1,ns2,ns3,fns1,fns2,fns3)
+!!PAR!! call ftran_wrap(SC,Zk,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+
+ Uk = Uk/real(nx**3.0,WP)
+ Vk = Vk/real(nx**3.0,WP)
+ Wk = Wk/real(nx**3.0,WP)
+!!PAR!! Zk = Zk/real(nxsc**3.0,WP)
+
+ call parallel_max(maxval(abs(Uk)),umax)
+ call parallel_max(maxval(abs(Vk)),vmax)
+ call parallel_max(maxval(abs(Wk)),wmax)
+
+ if (rank.eq.0) then
+ print *,' Maximum of U,V,W after trans',umax,vmax,wmax
+ endif
+
+
+
+!!$ call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+ allocate(nlx(fns1,fns2,fns3))
+ allocate(nly(fns1,fns2,fns3))
+ allocate(nlz(fns1,fns2,fns3))
+!!PAR!! allocate(nlmf(fns1sc,fns2sc,fns3sc))
+ allocate(nlu2x(fns1,fns2,fns3))
+ allocate(nlu2y(fns1,fns2,fns3))
+ allocate(nlu2z(fns1,fns2,fns3))
+
+!!$
+!!$ call parallel_max(maxval(abs(Uk)),umax)
+!!$ call parallel_max(maxval(abs(Vk)),vmax)
+!!$ call parallel_max(maxval(abs(Wk)),wmax)
+
+!!$ if (rank.eq.0) then
+!!$ print *,' Maximum U,V,W in solver',umax,vmax,wmax
+!!$ endif
+!!$
+!!$ if (umax.eq.maxval(abs(Uk))) then
+!!$ print *,' Maximum in rank', rank
+!!$ print *,' location ', maxloc(abs(Uk))
+!!$ gg = maxloc(abs(Uk))
+!!$ print *,' max value for conformation', Uk(gg(1),gg(2),gg(3))
+!!$ endif
+!!$
+!!$ if (wmax.eq.maxval(abs(Wk))) then
+!!$ print *,' Maximum in rank W', rank
+!!$ print *,' location W', maxloc(abs(Wk))
+!!$ gg = maxloc(abs(Wk))
+!!$ print *,' max value for W conformation', Wk(gg(1),gg(2),gg(3))
+!!$ endif
+
+ sim_time = 0.0_WP
+
+ call parser_read('Dealiasing',deal,0)
+
+ kmax = sqrt(3.0_WP)*kx(nx/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+!!PAR!! kmaxsc = sqrt(3.0_WP)*kxsc(nxsc/2+1) !sqrt(2.0_WP)*real(nx,WP)/3.0_WP !sqrt(3.0_WP)*real((nx/2+1),WP)
+ if (deal.eq.1) then
+ kcut = 2.0_WP/3.0_WP*kmax
+!!PAR!! kcutsc = 2.0_WP/3.0_WP*kmaxsc
+ else
+ kcut = 10000.0_WP
+!!PAR!! kcutsc = 10000.0_WP
+ endif
+
+ if (rank.eq.0) print*,'init : test3'
+
+ mu_solver = mu
+ diff_solver = diff
+
+ call parser_read('LES model',iles,0)
+ call parser_read('LES scalar model',ilessc,0)
+ call parser_read('y inhomogeneity',ydir,0)
+
+ call parser_read('Postprocessing',ipost,0)
+
+ call parser_read('Forcing',iforce,0)
+ if (iforce.eq.1) call forcing_init
+
+ call parser_read('Courant number', courant,0.5_WP)
+
+!!!! Determine if it is required to solver the scalar equation
+!!!! If running from scratch with forcing, dont solver scalar equation
+
+ call parser_read('Simulation type', itype)
+ call parser_read('Compute scalar', iscalar)
+ if (iscalar.eq.0) then
+ if (rank.eq.0) print *,'Not solving scalar transport equation .....'
+ endif
+
+ call parser_read('Imposing mean gradient',impose,0)
+ if (impose.eq.1) then
+ call parser_read('X-gradient',cx,0.0_WP)
+ call parser_read('Y-gradient',cy,0.0_WP)
+ call parser_read('Z-gradient',cz,0.0_WP)
+ else
+ cx = 0.0_WP
+ cy = 0.0_WP
+ cz = 0.0_WP
+ endif
+
+ spfilename = 'spectrum_solver.init'
+ spfilename2 = 'spectrum_solver.init.z'
+ call get_dns_numbers(0)
+
+ if (rank.eq.0) print*,'init : test4'
+
+ print*,'test U init solver', U(1,1,1), V(1,1,1),W(1,1,1)
+
+end subroutine solver_init
+
+
+
+subroutine solver_step
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ complex(WP), dimension(:,:,:), allocatable :: Pressk
+ real(WP), dimension(:,:,:), allocatable :: tab
+ character(len=str_long) :: sim_name
+ real(WP) :: Ufz, Vfz, Wfz
+
+ integer :: i,j,k,ierr
+
+ real(WP) :: kk,h, divumax
+
+
+ if (rank.eq.0) print*,'test1'
+ print*,'test U solver 0', U(1,1,1), V(1,1,1),W(1,1,1)
+
+
+ allocate(Pressk(fns1,fns2,fns3))
+ allocate(tab(ns1,ns2,ns3))
+
+
+!!$ if (rank.eq.0) print *,' Viscosity', mu_solver
+!!!! GEL DU CHAMP DE VITESSE POUR LES TEST !!!!
+call parser_read('Simulation name', sim_name)
+if (trim(sim_name).eq.'Test case') then
+ call parser_read('Frozen U', Ufz)
+ call parser_read('Frozen V', Vfz)
+ call parser_read('Frozen W', Wfz)
+ U = Ufz
+ V = Vfz
+ W = Wfz
+ print*,'test U solver 1', U(1,1,1), V(1,1,1),W(1,1,1)
+endif
+
+ call get_timestep
+ sim_time = sim_time +dt
+
+!!!!!!!!!!!!
+!!! Second-order RK scheme
+!!!!!!!!!!!
+ h = dt/2.0_WP
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ Udummy(i,j,k) = Uk(i,j,k)
+ Vdummy(i,j,k) = Vk(i,j,k)
+ Wdummy(i,j,k) = Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! Zdummy(i,j,k) = Zk(i,j,k)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+ if (rank.eq.0) print*,'test2'
+
+ call non_linear
+
+ if (rank.eq.0) print*,'test3'
+! if (iforce.eq.1) call force_compute
+!!!!!! Step 1 for RK scheme
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Uk(i,j,k) + h*nlx(i,j,k))/exp(mu_solver*kk*h)
+ Vk(i,j,k) = (Vk(i,j,k) + h*nly(i,j,k))/exp(mu_solver*kk*h)
+ Wk(i,j,k) = (Wk(i,j,k) + h*nlz(i,j,k))/exp(mu_solver*kk*h)
+ enddo
+ enddo
+ enddo
+!!PAR!! if (iscalar.ne.0) then
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = kxsc(i)**2.0 + kysc(j)**2.0 + kzsc(k)**2.0
+!!PAR!! Zk(i,j,k) = (Zk(i,j,k) + h*nlmf(i,j,k))/exp(diff_solver*kk*h)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! end if
+
+
+!!$
+!!$!!!!!!! Step 2 for RK scheme
+!!$
+ call non_linear
+ if (iforce.eq.1) call force_compute
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ Uk(i,j,k) = (Udummy(i,j,k) + dt*nlx(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Vk(i,j,k) = (Vdummy(i,j,k) + dt*nly(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ Wk(i,j,k) = (Wdummy(i,j,k) + dt*nlz(i,j,k)*exp(mu_solver*kk*h))/exp(mu_solver*kk*dt)
+ enddo
+ enddo
+ enddo
+!!PAR!! if (iscalar.ne.0) then
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = kxsc(i)**2.0 + kysc(j)**2.0 + kzsc(k)**2.0
+!!PAR!! Zk(i,j,k) = (Zdummy(i,j,k) + dt*nlmf(i,j,k)*exp(diff_solver*kk*h))/exp(diff_solver*kk*dt)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! end if
+
+ ! Projection
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+ if(kk.gt.0.0_WP) then
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )/kk
+ end if
+ Uk(i,j,k) = Uk(i,j,k) - ii*kx(i)*Pressk(i,j,k)
+ Vk(i,j,k) = Vk(i,j,k) - ii*ky(j)*Pressk(i,j,k)
+ Wk(i,j,k) = Wk(i,j,k) - ii*kz(k)*Pressk(i,j,k)
+ Pressk(i,j,k) = - ( ii*kx(i)*Uk(i,j,k) + ii*ky(j)*Vk(i,j,k) + ii*kz(k)*Wk(i,j,k) )
+ end do
+ end do
+ end do
+! call btran_wrap(Pressk,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+! call parallel_max(maxval(abs(tab)),divumax)
+! if (rank.eq.0) print*,'divergence max = ', divumax
+! call parallel_max(maxval(abs(Uk)),divumax)
+! if (rank.eq.0) print*,'abs(Uk) max = ', divumax
+
+!!PAR!! - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+ if (nproc.ne.1) then
+ if (rank.eq.0) print*,'NOT AVAILABLE IN PARALLEL'
+ STOP
+ else
+
+!!PAR!! 1. on remet les vitesses dans l'espace physique
+ print*,'test U solver 2', U(1,1,1), V(1,1,1),W(1,1,1)
+ if (trim(sim_name).ne.'Test case') call u_compute !!!! GEL DU CHAMP DE VITESSE POUR LES TESTS !!!!
+
+ print*,'test U solver 3', U(1,1,1), V(1,1,1),W(1,1,1)
+
+!!PAR!! 2. appelle du transport particulaire
+ call x_advec
+ print*,'x advec done'
+ call y_advec
+ print*,'y advec done'
+ call z_advec
+ print*,'z advec done'
+! call z_advec
+
+ end if
+!!PAR!! - FIN - INTERFACAGE AVEC LA METHODE PARTICULAIRE
+
+
+
+ deallocate(Pressk)
+ deallocate(tab)
+
+
+end subroutine solver_step
+
+subroutine non_linear
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(:,:,:),allocatable :: ddx,ddy,ddz,nis
+ real(WP), dimension(:,:,:),allocatable :: us,vs,ws
+ real(WP), dimension(:,:,:),allocatable :: uss,vss,wss
+ complex(WP), dimension(:,:,:),allocatable :: ddxk,ddyk,ddzk
+ ! LES
+
+ complex(WP) :: knl
+ real(WP) :: kk
+
+ integer :: i,j,k
+ real(WP) :: umax,vmax,wmax
+
+ integer :: sizemess, tag, ierr, status(MPI_STATUS_SIZE)
+ integer :: yeloc, ysloc, yelocsc, yslocsc, rank2send1, rank2send2, fs1, fe1, fs2, fe2, fnysrank, fnyerank, cptrank
+
+
+
+ allocate(ddx(ns1,ns2,ns3))
+ allocate(ddy(ns1,ns2,ns3))
+ allocate(ddz(ns1,ns2,ns3))
+ allocate(nis(ns1,ns2,ns3))
+
+ allocate(ddxk(fns1,fns2,fns3))
+ allocate(ddyk(fns1,fns2,fns3))
+ allocate(ddzk(fns1,fns2,fns3))
+
+
+ allocate(us(ns1,ns2,ns3))
+ allocate(vs(ns1,ns2,ns3))
+ allocate(ws(ns1,ns2,ns3))
+
+!!!!!!!!!!!
+!! Convert velocity to spatial coordinates
+!!!!!!!!!!
+
+ call btran_wrap(Uk,us,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,vs,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,ws,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ call parallel_max(maxval(abs(us)),umax)
+!!$ call parallel_max(maxval(abs(vs)),vmax)
+!!$ call parallel_max(maxval(abs(ws)),wmax)
+!!$
+!!$! if (rank.eq.0) write(*,'(A10,3(E12.5,3X))') ' MAX VAL', umax,vmax,wmax
+
+
+!!$ if (rank.eq.0) print *,' After velocity conversion'
+
+
+!!!!!!!!!!
+!! Form the first term in the skew-symmetric form
+!!!!!!!!!
+
+
+!!!! U component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*us(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*us(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*us(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2x(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! V component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*vs(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*vs(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*vs(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2y(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+!!!! W component
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ ddx(i,j,k) = us(i,j,k)*ws(i,j,k)
+ ddy(i,j,k) = vs(i,j,k)*ws(i,j,k)
+ ddz(i,j,k) = ws(i,j,k)*ws(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(ddx,ddxk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddy,ddyk,ns1,ns2,ns3,fns1,fns2,fns3)
+ call ftran_wrap(ddz,ddzk,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ ddxk = ddxk/real(ns1**3.0,WP)
+ ddyk = ddyk/real(ns1**3.0,WP)
+ ddzk = ddzk/real(ns1**3.0,WP)
+
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlu2z(i,j,k) = ii*(kx(i)*ddxk(i,j,k) + &
+ &ky(j)*ddyk(i,j,k) + kz(k)*ddzk(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!! Compute the second term in the skew symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Uk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Uk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Uk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After btran in U computations'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product evaluations'
+
+ call ftran_wrap(nis,nlx,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After forward transforms'
+
+ nlx = nlx/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlx computation'
+
+!!!!!!!!!!!!!!
+!! Compute U products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Vk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Vk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Vk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After b trans in V compute'
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+!!$ if (rank.eq.0) print *,' After product eval. in V'
+
+ call ftran_wrap(nis,nly,ns1,ns2,ns3,fns1,fns2,fns3)
+
+!!$ if (rank.eq.0) print *,' After forward trans in V'
+
+ nly = nly/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nly computation'
+
+!!!!!!!!!!!!!!
+!! Compute W products
+!!!!!!!!!!!!!!
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ ddxk(i,j,k) = ii*kx(i)*Wk(i,j,k)
+ ddyk(i,j,k) = ii*ky(j)*Wk(i,j,k)
+ ddzk(i,j,k) = ii*kz(k)*Wk(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ ddx = 0.0_WP
+ ddy = 0.0_WP
+ ddz = 0.0_WP
+
+ call btran_wrap(ddxk,ddx,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddyk,ddy,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(ddzk,ddz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ nis(i,j,k) = us(i,j,k)*ddx(i,j,k) + &
+ & vs(i,j,k)*ddy(i,j,k) +&
+ & ws(i,j,k)*ddz(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call ftran_wrap(nis,nlz,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ nlz = nlz/real((ns1**3.0),WP)
+
+!!$ if (rank.eq.0) print *,' After nlz computation'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Form the complex skew-symmetric form
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+ nlx(i,j,k) = 0.5*(nlx(i,j,k) + nlu2x(i,j,k))
+ nly(i,j,k) = 0.5*(nly(i,j,k) + nlu2y(i,j,k))
+ nlz(i,j,k) = 0.5*(nlz(i,j,k) + nlu2z(i,j,k))
+ enddo
+ enddo
+ enddo
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!! Form non-linear term for the scalar
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ deallocate(ddx)
+ deallocate(ddy)
+ deallocate(ddz)
+ deallocate(ddxk)
+ deallocate(ddyk)
+ deallocate(ddzk)
+ deallocate(nis)
+
+
+!!PAR!! if (iscalar.eq.0) then
+
+ deallocate(us)
+ deallocate(vs)
+ deallocate(ws)
+!!PAR!! nlmf = 0.0_WP
+
+!!PAR!! else
+
+!!PAR!! allocate(ddx(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddy(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(ddz(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(nis(ns1sc,ns2sc,ns3sc))
+
+!!PAR!! allocate(ddxk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddyk(fns1sc,fns2sc,fns3sc))
+!!PAR!! allocate(ddzk(fns1sc,fns2sc,fns3sc))
+
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! ddxk(i,j,k) = ii*kxsc(i)*Zk(i,j,k)
+!!PAR!! ddyk(i,j,k) = ii*kysc(j)*Zk(i,j,k)
+!!PAR!! ddzk(i,j,k) = ii*kzsc(k)*Zk(i,j,k)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+!!PAR!! ddx = 0.0_WP
+!!PAR!! ddy = 0.0_WP
+!!PAR!! ddz = 0.0_WP
+
+!!PAR!! call btran_wrap(ddxk,ddx,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddyk,ddy,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! call btran_wrap(ddzk,ddz,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+!!PAR!! deallocate(ddxk)
+!!PAR!! deallocate(ddyk)
+!!PAR!! deallocate(ddzk)
+
+!!PAR!! allocate(uss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(vss(ns1sc,ns2sc,ns3sc))
+!!PAR!! allocate(wss(ns1sc,ns2sc,ns3sc))
+!!PAR!! uss = 0.0
+!!PAR!! vss = 0.0
+!!PAR!! wss = 0.0
+
+!!PAR!! if (ns1sc.gt.ns1) then
+!!PAR!! call discretisation2(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation2(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else if (ns1sc.lt.ns1) then
+!!PAR!! call discretisation3(us,uss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(vs,vss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! call discretisation3(ws,wss,ns1,ns2,ns3,ns1sc,ns2sc,ns3sc)
+!!PAR!! else
+!!PAR!! uss = us
+!!PAR!! vss = vs
+!!PAR!! wss = ws
+!!PAR!! end if
+
+!!PAR!! deallocate(us)
+!!PAR!! deallocate(vs)
+!!PAR!! deallocate(ws)
+
+!!PAR!! do k = 1,ns3sc
+!!PAR!! do j = 1,ns2sc
+!!PAR!! do i = 1,ns1sc
+!!PAR!! nis(i,j,k) = uss(i,j,k)*(ddx(i,j,k)+cx) + &
+!!PAR!! & vss(i,j,k)*(ddy(i,j,k)+cy) +&
+!!PAR!! & wss(i,j,k)*(ddz(i,j,k)+cz)
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! deallocate(uss)
+!!PAR!! deallocate(vss)
+!!PAR!! deallocate(wss)
+!!PAR!! deallocate(ddx)
+!!PAR!! deallocate(ddy)
+!!PAR!! deallocate(ddz)
+
+!!PAR!! call ftran_wrap(nis,nlmf,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+!!PAR!! nlmf = nlmf/real((ns1sc**3.0),WP)
+
+!!PAR!! deallocate(nis)
+
+
+!!PAR!! endif
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! Dealias the non-linear term
+
+ call dealias
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!! LES MODEL
+
+if (iles.ne.0) then
+! if (iles.eq.1) call smagmodel
+! if (iles.eq.2) call dynsmagmodel
+! if (iles.eq.8) call SISM
+! if (iles.eq.12) call dynsmagmodel2
+! if (iles.eq.13) call dynsmagmodel3
+endif
+if (ilessc.ne.0) then
+! if (ilessc.eq.1) call smagmodelsca
+! if (ilessc.eq.2) call dynsmagmodelsca
+! if (ilessc.eq.3) call dynsmagmodelscanew
+! if (ilessc.eq.4) call dynsmagmodelscacut
+! if (ilessc.eq.5) call dynsmagmodelscanewcut
+! if (ilessc.eq.6) call dynsfmodelscacut
+! if (ilessc.eq.7) call dynsfmodelscanewcut
+! if (ilessc.eq.8) call dynsigmamodelscacut
+! if (ilessc.eq.9) call dynsigmamodelscanewcut
+! if (ilessc.eq.12) call dyndd2modelscacut
+! if (ilessc.eq.13) call dyndd4modelscacut
+! if (ilessc.eq.14) call dynddsmagmodelscanewcut
+! if (ilessc.eq.15) call dynsflpmodelscacut
+! if (ilessc.eq.16) call ssmodelscacut
+! if (ilessc.eq.17) call dynsmagtestmodelscacut
+endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!!!!!!!
+!! Form the pressure term and add it to the nonlinear term
+!!!!!!!!!!
+
+!! SEMBLE NE PAS DONNER DIV(U)=0. ???
+!!
+!! do k = 1,fns3
+!! do j = 1,fns2
+!! do i = 1,fns1
+!!
+!! kk = kx(i)**2.0 + ky(j)**2.0 + kz(k)**2.0
+!! if (sqrt(kk).gt.kmin) then
+!! knl = kx(i)*nlx(i,j,k) + ky(j)*nly(i,j,k) +&
+!! & kz(k)*nlz(i,j,k)
+!! nlx(i,j,k) = kx(i)*knl/kk - nlx(i,j,k)
+!! nly(i,j,k) = ky(j)*knl/kk - nly(i,j,k)
+!! nlz(i,j,k) = kz(k)*knl/kk - nlz(i,j,k)
+!! nlmf(i,j,k) = -nlmf(i,j,k)
+!! else
+!! nlx(i,j,k) = 0.0_WP
+!! nly(i,j,k) = 0.0_WP
+!! nlz(i,j,k) = 0.0_WP
+!! nlmf(i,j,k) = 0.0_WP
+!!!!!!!!!!!!!!!INSTEAD
+ nlx = -nlx
+ nly = -nly
+ nlz = -nlz
+!!PAR!! nlmf = -nlmf
+!! endif
+!! enddo
+!! enddo
+!! enddo
+
+
+end subroutine non_linear
+
+
+subroutine get_timestep
+
+ use solver
+ use parallel
+ use data
+
+ real(WP) :: max_s, max_sg
+
+ integer :: ierr,nn
+
+ max_s = 0.0_WP
+ max_sg = 0.0_WP
+
+!!!! GEL DU CHAMP DE VITESSE POUR LES TEST !!!! call u_compute
+ print*,'test U get_timestep 1', U(1,1,1), V(1,1,1),W(1,1,1)
+
+ max_s = maxval(abs(U) +abs(V)+abs(W))
+
+
+ call MPI_ALLREDUCE(max_s,max_sg,1,MPI_REAL_WP,MPI_MAX,&
+ &MPI_COMM_WORLD,ierr)
+
+ call parser_read('fixed time step',dt)
+
+ if (dt.eq.0) then
+ if (max_sg.gt.0.0_WP) then
+ nn = nx
+!!PAR!! if(iscalar.ne.0) nn = max(nx,nxsc)
+ dt = courant/max_sg*(L/nn)
+ else
+ print *,' SOMETHING WRONG IN TIME_STEP', rank, max_sg,max_s,nx
+ stop
+ endif
+ endif
+
+
+!!$ print *,' MAX_TIME ', dt
+
+end subroutine get_timestep
+
+
+subroutine dealias
+
+ use solver
+ use parallel
+ use precision
+
+ implicit none
+
+ real(WP) :: kk
+ integer :: i,j,k
+
+ do k = 1,fns3
+ do j = 1,fns2
+ do i = 1,fns1
+
+ kk = sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+ ! kk = sqrt(kk)
+! if ((abs(kz(k)).gt.kmax).or.(abs(ky(j)).gt.kmax).or.(abs(kx(i)).gt.kmax)) then
+! if (kk.gt.kmax) then
+ if (kk.gt.kcut) then
+ nlx(i,j,k) = 0.0_WP
+ nly(i,j,k) = 0.0_WP
+ nlz(i,j,k) = 0.0_WP
+ endif
+ enddo
+ enddo
+ enddo
+!!PAR!! do k = 1,fns3sc
+!!PAR!! do j = 1,fns2sc
+!!PAR!! do i = 1,fns1sc
+!!PAR!! kk = sqrt(kxsc(i)**2.0_WP + kysc(j)**2.0_WP + kzsc(k)**2.0_WP)
+!!PAR!! if (kk.gt.kcutsc) then
+!!PAR!! nlmf(i,j,k) = 0.0_WP
+!!PAR!! endif
+!!PAR!! enddo
+!!PAR!! enddo
+!!PAR!! enddo
+
+end subroutine dealias
+
+subroutine fourier_write
+ use solver
+
+! call data_write_fourier(Uk,Vk,Wk,fns1,fns2,fns3)
+
+end subroutine fourier_write
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/string.f90 b/CodesEnVrac/Remesh/FFTPAR/string.f90
new file mode 100755
index 0000000000000000000000000000000000000000..1964ca2b93c943ce19de0271cd677a05be3c191a
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/string.f90
@@ -0,0 +1,7 @@
+module string
+ implicit none
+ integer, parameter :: str_short = 8
+ integer, parameter :: str_medium = 64
+ integer, parameter :: str_long = 4096
+end module string
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/tg_init.f90 b/CodesEnVrac/Remesh/FFTPAR/tg_init.f90
new file mode 100755
index 0000000000000000000000000000000000000000..462520e79752b0e5230c16c32eeb34f1f1350686
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/tg_init.f90
@@ -0,0 +1,48 @@
+subroutine tg_init
+
+ use parallel
+ use data
+
+
+ implicit none
+
+ integer :: i,j,k,tgdim
+ real(WP) :: dx,per,acos,yj,zk,xi,factor
+
+
+ call parser_read('Length of domain',L)
+ call parser_read('Number of points', nx)
+ call parser_read('TG dimensions',tgdim,1)
+
+
+ dx = L/real(nx-1,WP)
+ per = 0.5*L/acos(-1.0)
+
+ if (tgdim.eq.1) then
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ yj = real(j+nys-1,WP)*dx
+ zk = real(k+nzs-1,WP)*dx
+ U(i,j,k) = 0.0_WP
+ V(i,j,k) = cos(yj/per)*sin(zk/per)
+ W(i,j,k) = -sin(yj/per)*cos(zk/per)
+ enddo
+ enddo
+ enddo
+ else
+ do k = 1,ns3
+ do j = 1,ns2
+ do i = 1,ns1
+ xi = real(i+nxs-1,WP)*dx
+ yj = real(j+nys-1,WP)*dx
+ zk = real(k+nzs-1,WP)*dx
+ U(i,j,k) = sin(xi)*cos(yj)*cos(zk)
+ V(i,j,k) = -cos(xi)*sin(yj)*cos(zk)
+ W(i,j,k) = 0.0
+ enddo
+ enddo
+ enddo
+ endif
+
+end subroutine tg_init
diff --git a/CodesEnVrac/Remesh/FFTPAR/tools.f90 b/CodesEnVrac/Remesh/FFTPAR/tools.f90
new file mode 100755
index 0000000000000000000000000000000000000000..81435626c9af50c4bcac1cb19285b5015a6b7ecb
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/tools.f90
@@ -0,0 +1,668 @@
+subroutine dns_stats
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP), dimension(2,nx+1) :: S1,S2,S
+ real(WP), dimension(ns1,ns2,ns3) :: tab,tab1
+ real(WP), dimension(:,:,:), allocatable :: SCO, SCO2
+ real(WP),dimension(ns1sc,ns2sc,ns3sc) :: tabsc
+ complex(WP),dimension(fns1,fns2,fns3) :: tabf
+! real(WP),dimension(ns1,ns2,ns3) :: tabx,taby,tabz
+! complex(WP),dimension(fns1,fns2,fns3) :: tabfx,tabfy,tabfz
+ real(WP) :: esum, k2sum,lambda_t,Re_lambda,uturb,divumax
+ real(WP) :: buf,grms,drms,lambda,buf1
+
+ integer :: k,i,j,ierr,ik,nxo,nxoz
+ real(WP) :: kk,umax,vmax,wmax,cos,pi,kc,eps,e_spec,zmax,zstat2,zstat,zstat2o,zstato
+
+ S = 0.0_WP
+ S1 = 0.0_WP
+ S2 = 0.0_WP
+ call u_compute
+
+ pi = acos(-1.0_WP)
+! dk = 2.0_WP*pi/L
+! kc = pi*nx/L
+! eps = kc/1000000_WP
+!
+! do k = 1,fns3
+! do j = 1,fns2
+! do i = 1,fns1
+! kk= sqrt(kx(i)**2.0_WP + ky(j)**2.0_WP + kz(k)**2.0_WP)
+! ik = 1+idint(kk/dk+0.5_WP)
+! if (kk.gt.eps.and.kk.le.kc) then
+! e_spec = (real(Uk(i,j,k)*conjg(Uk(i,j,k))) + &
+! & real(Vk(i,j,k)*conjg(Vk(i,j,k))) +&
+! & real(Wk(i,j,k)*conjg(Wk(i,j,k))))
+! S1(2,ik) = S1(2,ik) + e_spec
+! S2(2,ik) = S2(2,ik) + 2*mu*kk**2.0_WP*e_spec
+! endif
+! enddo
+! enddo
+! enddo
+! do i = 1,nx+1
+! S1(1,i) = real(i-1,WP)*dk
+! S2(1,i) = real(i-1,WP)*dk
+! enddo
+! S = S1
+!
+! call MPI_ALLREDUCE(S1(2,:),S(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+! &MPI_COMM_WORLD,ierr)
+!
+! S1 = S
+!
+! call MPI_ALLREDUCE(S2(2,:),S(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+! &MPI_COMM_WORLD,ierr)
+!
+! S2 = S
+!
+! esum = 0.0_WP
+! k2sum = 0.0_WP
+! do k = 1,nx+1
+! kk = S(1,k)
+! esum = esum + S1(2,k)
+! k2sum = k2sum + S2(2,k)
+! enddo
+! lambda_t = sqrt(5*esum/k2sum)
+!-----urms
+ tab=U**2+V**2+W**2
+ buf=0.
+ do k=1,ns3
+ do j=1,ns2
+ do i=1,ns1
+ buf=buf+tab(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,grms,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+! print*,"U rms =",grms/(ns1**3.)
+!-----<dudx^2>+<dvdy^2>+<dwdz^2>
+ buf=0.
+ tab=0.
+ tabf=0.
+ do k=1,fns3
+ do j=1,fns2
+ tabf(:,j,k) = ii*kx(:)*Uk(:,j,k)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ do k=1,ns3
+ do j=1,ns2
+ do i=1,ns1
+ buf=buf+tab(i,j,k)**2.
+ enddo
+ enddo
+ enddo
+ tab=0.
+ tabf=0.
+ do k=1,fns3
+ do i=1,fns1
+ tabf(i,:,k) = ii*ky(:)*Vk(i,:,k)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ do k=1,ns3
+ do j=1,ns2
+ do i=1,ns1
+ buf=buf+tab(i,j,k)**2.
+ enddo
+ enddo
+ enddo
+ tab=0.
+ tabf=0.
+ do j=1,fns2
+ do i=1,fns1
+ tabf(i,j,:) = ii*kz(:)*Wk(i,j,:)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ do k=1,ns3
+ do j=1,ns2
+ do i=1,ns1
+ buf=buf+tab(i,j,k)**2.
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,drms,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+!----
+!---divergence
+! -- divergences
+!- velocity
+ tab1=0.
+ tab=0.
+ tabf=0.
+ do k=1,fns3
+ do j=1,fns2
+ tabf(:,j,k) = ii*kx(:)*Uk(:,j,k)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ tab1 = tab
+ tab=0.
+ tabf=0.
+ do k=1,fns3
+ do i=1,fns1
+ tabf(i,:,k) = ii*ky(:)*Vk(i,:,k)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ tab1 = tab1 + tab
+ tab=0.
+ tabf=0.
+ do j=1,fns2
+ do i=1,fns1
+ tabf(i,j,:) = ii*kz(:)*Wk(i,j,:)
+ enddo
+ enddo
+ call btran_wrap(tabf,tab,ns1,ns2,ns3,fns1,fns2,fns3)
+ tab1 = tab1 + tab
+ call parallel_max(maxval(abs(tab1)),divumax)
+!----
+ lambda = sqrt(grms/drms)
+ uturb = sqrt(grms/(3.*real(nx**3,WP)))
+ Re_lambda = uturb*lambda/mu_solver
+
+ call parallel_max(maxval(abs(U)),umax)
+ call parallel_max(maxval(abs(V)),vmax)
+ call parallel_max(maxval(abs(W)),wmax)
+ call parallel_max(maxval(abs(SC)),zmax)
+ tabsc=SC**2
+ buf=0.
+ buf1=0.
+ do k=1,ns3sc
+ do j=1,ns2sc
+ do i=1,ns1sc
+ buf=buf+tabsc(i,j,k)
+ buf1=buf1+SC(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,zstat2,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(buf1,zstat,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ zstat=zstat/(real(nxsc**3,WP))
+ zstat2=zstat2/(real(nxsc**3,WP))
+ zstat2 = (zstat2 - zstat**2.)**(0.5)
+
+ call parser_read('Nx filter output',nxo,0)
+ if (nxo.lt.ns1sc.and.nxo.ne.0) then
+ nxoz = nxo / nproc
+ allocate(SCO(nxo,nxo,nxoz))
+ allocate(SCO2(nxo,nxo,nxoz))
+ call discretisation3(SC,SCO,ns1sc,ns2sc,ns3sc,nxo,nxo,nxoz)
+ SCO2=SCO**2.0
+ buf=0.
+ buf1=0.
+ do k=1,nxoz
+ do j=1,nxo
+ do i=1,nxo
+ buf=buf+SCO2(i,j,k)
+ buf1=buf1+SCO(i,j,k)
+ enddo
+ enddo
+ enddo
+ call MPI_ALLREDUCE(buf,zstat2o,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ call MPI_ALLREDUCE(buf1,zstato,1,MPI_REAL_WP,MPI_SUM, &
+ MPI_COMM_WORLD,ierr)
+ zstato=zstato/(real(nxo**3,WP))
+ zstat2o=zstat2o/(real(nxo**3,WP))
+ zstat2o = (zstat2o - zstato**2.)**(0.5)
+ deallocate(SCO)
+ deallocate(SCO2)
+ end if
+
+ if (rank.eq.0) then
+! print*,grms,drms,lambda,uturb,mu_solver
+ write(*,'(A10,8(E12.5,2X))') 'STEP ', sim_time,Re_lambda,uturb,umax,divumax,zmax,zstat2,zstat2o
+ endif
+
+
+
+end subroutine dns_stats
+
+subroutine u_compute
+
+ use solver
+ use data
+ use parallel
+
+ implicit none
+
+ real(WP) :: Uloc(ns1,ns2,ns3)
+ real(WP) :: Vloc(ns1,ns2,ns3)
+ real(WP) :: Wloc(ns1,ns2,ns3)
+
+ call btran_wrap(Uk,Uloc,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,Vloc,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,Wloc,ns1,ns2,ns3,fns1,fns2,fns3)
+
+ U = Uloc
+ V = Vloc
+ W = Wloc
+
+end subroutine u_compute
+
+subroutine uz_compute
+
+ use solver
+ use data
+ use parallel
+
+ implicit none
+
+ real(WP) :: Uloc(ns1,ns2,ns3)
+ real(WP) :: Vloc(ns1,ns2,ns3)
+ real(WP) :: Wloc(ns1,ns2,ns3)
+ real(WP) :: SCloc(ns1sc,ns2sc,ns3sc)
+
+ call btran_wrap(Uk,Uloc,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Vk,Vloc,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Wk,Wloc,ns1,ns2,ns3,fns1,fns2,fns3)
+ call btran_wrap(Zk,SCloc,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc)
+
+ U = Uloc
+ V = Vloc
+ W = Wloc
+ SC = SCloc
+
+end subroutine uz_compute
+
+
+subroutine get_spectrum(Bdummy,nx1,nx2,nx3,fnx1,fnx2,fnx3,L,Sg,Sg1)
+
+ use transform
+ use precision
+ use parallel
+
+ implicit none
+! include 'fftw3.f'
+
+ integer :: nx1,nx2,nx3
+ integer :: fnx1,fnx2,fnx3
+ integer :: fn1zs,fn1ze,fn1ys,fn1ye,fn1xs,fn1xe
+ real(WP), dimension(2,nx1+1) :: S, Sg, Sg1
+ real(WP), dimension(nx1,nx2,nx3) :: Bdummy
+ real(WP) :: ke,kd,ks,dk,ksk0ratio,kc,kcksratio,kk,kx,ky,kz,kk2
+
+
+ real(WP), dimension(:,:,:), pointer :: Rbuf
+
+ real(WP), dimension(:,:,:), pointer :: in
+ complex(WP), dimension(:,:,:), pointer :: out
+
+ integer :: ierr
+ integer :: i,j,k,ik,iunit,gg(3)
+ integer :: il,jl,kl,nkk
+ complex(WP) :: ii=(0.0_WP,1.0_WP)
+ real(WP) :: rand,pi,eps,L,gmax
+
+ integer(KIND=8) :: plan_3d
+
+ real(WP), dimension(nx1+1) :: nnodes
+ real(WP) :: node_density
+
+
+
+
+ allocate(Rbuf(fnx1,fnx2,fnx3))
+ allocate(A(nx1,nx2,nx3))
+ allocate(B(fnx1,fnx2,fnx3))
+ allocate(C(fnx1,fnx2,fnx3))
+ allocate(D(fnx1,fnx3,fnx2))
+
+
+ do k = 1,nx3
+ do j = 1,nx2
+ do i = 1,nx1
+ A(i,j,k) = Bdummy(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call forward_transform(nx1,nx2,nx3,fnx1,fnx2,fnx3)
+
+ do k = 1,fnx3
+ do j = 1,fnx2
+ do i = 1,fnx1
+ B(i,j,k) = B(i,j,k)/real(nx1**3.0,WP)
+ Rbuf(i,j,k) = sqrt(real(B(i,j,k)*conjg(B(i,j,k)),WP))
+ enddo
+ enddo
+ enddo
+
+
+
+
+ Sg = 0.0_WP
+ Sg1 = 0.0_WP
+ nnodes = 0.0_WP
+
+ ! Create pi
+ pi = acos(-1.0_WP)
+
+ ! =================
+ ! Velocity Spectrum
+
+ ! Spectrum computation
+
+ dk = 2.0_WP*pi/L
+ kc = pi*nx1/L
+ eps=kc/1000000.0_WP
+
+ nkk = nx1/2+1
+ fn1zs = 1
+ fn1ze = fnx3
+ fn1ys = 1 + (rank)*fnx2
+ fn1ye = (rank+1)*fnx2
+ fn1xs = 1
+ fn1xe = nkk
+
+ do k = fn1zs,fn1ze
+ do j = fn1ys,fn1ye
+ do i = fn1xs,fn1xe
+ il = i-fn1xs+1
+ jl = j-fn1ys+1
+ kl = k-fn1zs+1
+ ! Wavenumbers
+ kx=real(i-1,WP)*dk
+! if (i.gt.(nkk)) kx=-real(nx1-i+1,WP)*dk
+ ky=real(j-1,WP)*dk
+ if (j.gt.nkk) ky=-real(nx1-j+1,WP)*dk
+ kz=real(k-1,WP)*dk
+ if (k.gt.nkk) kz=-real(nx1-k+1,WP)*dk
+ kk=sqrt(kx**2+ky**2+kz**2)
+ ! Spectrum
+ ik=1+idint(kk/dk+0.5_WP)
+!!$ nnodes(ik) = nnodes(ik) + 1.0_WP
+ if ((kk.gt.eps).and.(kk.le.kc)) then
+!!$ if (i.gt.1) then
+ Sg(2,ik)=Sg(2,ik)+(Rbuf(il,jl,kl)**2)
+ Sg1(2,ik) = Sg1(2,ik) + kk**2.0_WP*(Rbuf(il,jl,kl)**2)
+!!$ else
+!!$ S(2,ik)=S(2,ik)+0.5_WP*(Rbuf(il,jl,kl)**2)/dk
+!!$ endif
+ end if
+ end do
+ end do
+ end do
+
+
+ do ik=1,nx1+1
+ Sg(1,ik)=real(dk*(ik-1),WP)
+ Sg1(1,ik)=real(dk*(ik-1),WP)
+ end do
+
+
+
+ deallocate(Rbuf)
+
+
+ deallocate(A)
+ deallocate(B)
+ deallocate(C)
+ deallocate(D)
+
+
+end subroutine get_spectrum
+
+subroutine get_dns_numbers(iinfo)
+
+ use parallel
+ use data
+ implicit none
+
+ real(WP) :: pi
+ real(WP) :: ke,mu_cin,dx
+ real(WP) :: kcin,epsi,l11,lt,re_turb,tau_epsi,l_k,tau_k
+
+ real(WP) :: keta, L_large,dk,eta,dissipation,tke,Rlambda
+ real(WP), dimension(:,:), pointer :: S1,S2,S3,Sg
+ real(WP), dimension(:,:), pointer :: S11,S21,S31,Sg1
+
+
+
+ integer :: i, iunit, ierr, iinfo
+
+
+
+
+
+ allocate(S1(2,nx+1),S2(2,nx+1),S3(2,nx+1),Sg(2,nx+1))
+ allocate(S11(2,nx+1),S21(2,nx+1),S31(2,nx+1),Sg1(2,nx+1))
+
+ Sg = 0.0_WP
+
+ S1 = 0.0_WP
+ S2 = 0.0_WP
+ S3 = 0.0_WP
+
+
+ call get_spectrum(V,ns1,ns2,ns3,fns1,fns2,fns3,L,S1,S11)
+ call get_spectrum(U,ns1,ns2,ns3,fns1,fns2,fns3,L,S2,S21)
+ call get_spectrum(W,ns1,ns2,ns3,fns1,fns2,fns3,L,S3,S31)
+
+ Sg(1,:) = S1(1,:)
+ Sg(1,:) = S11(1,:)
+
+ S1 = S1 + S2 + S3
+ S11 = S11 + S21 + S31
+
+ call MPI_ALLREDUCE(S1(2,:),Sg(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+ call MPI_ALLREDUCE(S11(2,:),Sg1(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+ if (rank.eq.0) then
+ iunit = iopen()
+ open(iunit,file=trim(adjustl(spfilename)),form='formatted')
+
+ do i = 1,nx+1
+ if ((Sg(1,i).ne.0.0_WP).and.(Sg(2,i).ne.0.0_WP)) then
+ write(11,*) Sg(1,i), Sg(2,i)
+ endif
+ enddo
+ close(iclose(iunit))
+ endif
+
+ call parser_read('Kmax eta', keta)
+
+
+
+ pi = acos(-1.0_WP)
+ dx = L/real(nx,WP)
+ tke = 0.0_WP
+ dissipation = 0.0_WP
+
+ do i = 1,nx+1
+ tke = tke + Sg(2,i)
+ dissipation = dissipation + 2*mu*Sg1(2,i)
+ enddo
+
+ Ut = sqrt(tke/1.5_WP)
+ eta = (2.0_WP*keta)/real(nx,WP)
+ re_turb = tke**2.0/(dissipation*mu)
+ Rlambda = sqrt(20.0_WP/3.0_WP*re_turb)
+
+ lt = eta*(3.0_WP/20.0_WP*Rlambda*Rlambda)**(3.0/4.0)
+ L11 = lt*0.43
+
+
+ ke = 1.3_WP/L11
+ dk = 2.0_WP*pi/L
+
+ tau_epsi = tke/dissipation
+ tau_k = sqrt(mu/dissipation)
+
+
+
+ if (rank.eq.0.and.iinfo.eq.1) then
+
+ write(*,*)
+ write(*,*) ' ======================================== '
+ write(*,*)' Debugging turbulent values '
+ write(*,*)' ---------------------------------------- '
+ if (trim(spectrum).eq.'PP') then
+ write(*,*)' -Spectrum type ----------> Passot-Pouquet'
+ else if (trim(spectrum).eq.'VKP') then
+ write(*,*)' -Spectrum type ----------> Von Karman-Pao'
+ end if
+ write(*,*)' Viscosity '
+ write(*,*)' mu ------->', mu
+ write(*,*)' -Turbulent Reynolds '
+ write(*,*)' Re_t --------> ', re_turb
+ write(*,*)' -Turbulent kinetic energy '
+ write(*,*)' k -----------> ', tke
+ write(*,*)' -Turbulent dissipation rate '
+ write(*,*)' epsilon -----> ', dissipation
+ write(*,*)' -Size of the biggest eddy '
+ write(*,*)' l_t ---------> ', lt
+ write(*,*)' C1 ----------> ', L/lt
+ write(*,*)' -Eddy turn over time '
+ write(*,*)' tau ---------> ', tau_epsi
+ write(*,*)' -Kolmogorov scale '
+ write(*,*)' l_k ---------> ', eta
+ write(*,*)' C2 ----------> ', eta/dx
+ write(*,*)' -Kolmogorov time scale '
+ write(*,*)' tau_k -------> ', tau_k
+ write(*,*)' -Reynolds lambda '
+ write(*,*)' Re_lambda ---> ', Rlambda
+ if (trim(spectrum).eq.'PP') then
+ write(*,*)' -Integral length scale '
+ write(*,*)' Lii --------> ', l11
+ write(*,*)' -Turbulent Reynolds based on Lii '
+ write(*,*)' Re_Lii -----> ', Ut*l11/mu
+ end if
+ write(*,*)' ======================================== '
+
+ endif
+
+ deallocate(S1,S2,S3,Sg)
+ deallocate(S11,S21,S31,Sg1)
+ allocate(S3(2,nxsc+1),Sg(2,nxsc+1))
+ allocate(S31(2,nxsc+1),Sg1(2,nxsc+1))
+ S3 = 0.0
+ S31 = 0.0
+ call get_spectrum(SC,ns1sc,ns2sc,ns3sc,fns1sc,fns2sc,fns3sc,L,S3,S31)
+ Sg(1,:) = S3(1,:)
+ Sg(1,:) = S31(1,:)
+ call MPI_ALLREDUCE(S3(2,:),Sg(2,:),nxsc+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+ call MPI_ALLREDUCE(S31(2,:),Sg1(2,:),nxsc+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+
+ if (rank.eq.0) then
+ iunit = iopen()
+ open(iunit,file=trim(adjustl(spfilename2)),form='formatted')
+
+ do i = 1,nxsc+1
+ if ((Sg(1,i).ne.0.0_WP).and.(Sg(2,i).ne.0.0_WP)) then
+ write(11,*) Sg(1,i), Sg(2,i)
+ endif
+ enddo
+ close(iclose(iunit))
+ endif
+ deallocate(S3,Sg)
+ deallocate(S31,Sg1)
+
+
+end subroutine get_dns_numbers
+
+
+subroutine tg_stats
+
+ use solver
+ use parallel
+ use data
+
+ implicit none
+
+ real(WP) :: umax,vmax,wmax,nmax
+ real(WP),dimension(2,nx+1) :: S1,S
+ real(WP) :: esum, k2sum,lambda_t,Re_lambda,uturb
+
+ integer :: k,ierr
+ real(WP) :: kk
+
+
+
+ S = 0.0_WP
+ S1 = 0.0_WP
+
+ call u_compute
+ call get_spectrum(U,ns1,ns2,ns3,L,S1)
+ S = S1
+ call get_spectrum(V,ns1,ns2,ns3,L,S1)
+ S = S + S1
+ call get_spectrum(W,ns1,ns2,ns3,L,S1)
+ S = S + S1
+
+ S(1,:) = S1(1,:)
+ S1 = S
+
+ call MPI_ALLREDUCE(S1(2,:),S(2,:),nx+1,MPI_REAL_WP,MPI_SUM,&
+ &MPI_COMM_WORLD,ierr)
+
+ esum = 0.0_WP
+ k2sum = 0.0_WP
+ do k = 1,nx+1
+ kk = S1(1,k)
+ esum = esum + S(2,k)
+ k2sum = k2sum + S(2,k)*S1(1,k)**2.0
+ enddo
+ lambda_t = sqrt(5*esum/k2sum)
+ uturb = sqrt(2.0_WP/3.0_Wp*esum)
+ if (mu.gt.0.0_WP) then
+ Re_lambda = lambda_t*uturb/mu
+ else
+ Re_lambda = 0.0_WP
+ endif
+
+
+ call parallel_max(maxval(abs(U)),umax)
+ call parallel_max(maxval(abs(V)),vmax)
+ call parallel_max(maxval(abs(W)),wmax)
+
+ if (rank.eq.0) then
+ write(*,'(A7,4(E12.5,3X),2E15.8)') 'STEP ', sim_time, umax, vmax,wmax,k2sum,esum
+ endif
+
+
+
+end subroutine tg_stats
+
+
+real(WP) function spec(ka,kb,ke)
+
+ use precision
+
+ implicit none
+ real(WP) :: e,dk,ka,kb,ke,integ,k
+ integer :: i,n
+
+ n = 1000
+
+ dk = (kb-ka)/real(n,WP)
+
+ integ = 0.0_WP
+ k = ka
+ do i =1,n
+ k = k + dk
+ integ = integ + (k/ke)**4.0_WP*exp(-2.0_WP*(k/ke)**2.0_WP)*dk
+ enddo
+ spec = integ/(kb-ka)
+
+end function spec
+
+
+
diff --git a/CodesEnVrac/Remesh/FFTPAR/transforms.f90 b/CodesEnVrac/Remesh/FFTPAR/transforms.f90
new file mode 100755
index 0000000000000000000000000000000000000000..3c2d56b1a92eea726f87579d8e91cf50153f3b88
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/transforms.f90
@@ -0,0 +1,329 @@
+module transform
+
+ use precision
+ use parallel
+ implicit none
+ include 'fftw3.f'
+
+ real(WP), dimension(:,:,:), pointer :: A !_real (ns1,ns2,ns3)
+ complex(WP), dimension(:,:,:), pointer :: B !_complex (fns1,fns2,fns3)
+ complex(WP), dimension(:,:,:), pointer :: C !_dummy (fns1,fns2,fns3)
+ complex(WP), dimension(:,:,:), pointer :: D !_dummy (fns1,fns3,fns2)
+end module transform
+
+
+subroutine forward_transform(n1,n2,n3,fn1,fn2,fn3)
+
+ use transform
+ implicit none
+
+ integer :: nsize(2),idim,istride,idist,ostride,odist
+ integer :: idim2,istride2,idist2,ostride2,odist2
+ integer :: inem(3),onem(3),howmany
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ integer(KIND=8) :: plan_mf1,plan_mf2
+
+
+ integer, parameter :: NULL = 0
+
+ integer :: nsize1
+
+ idim = 2
+ nsize(1) = n1
+ nsize(2) = n2
+ inem(1) = n1
+ inem(2) = n2
+ inem(3) = n3
+ istride = 1
+ idist = n1*n2
+
+ onem(1) = fn1
+ onem(2) = fn3
+ onem(3) = fn2
+ ostride = 1
+ odist = fn1*fn3
+
+ call dfftw_plan_many_dft_r2c(plan_mf1,idim,nsize,n3,A,inem,istride,idist,D,onem,ostride,odist,FFTW_ESTIMATE)
+ call dfftw_execute_dft_r2c(plan_mf1,A,D)
+ call dfftw_destroy_plan(plan_mf1)
+
+ call transpose_forward(n1,n2,n3,fn1,fn2,fn3) !(D,B)
+
+ idim2 = 1
+ nsize1 = fn3
+ howmany = fn1*fn2
+
+ inem(1) = fn1
+ inem(2) = fn2
+ inem(3) = fn3
+ istride2 = fn1*fn2
+ idist2 = 1
+
+ onem(1) = fn1
+ onem(2) = fn2
+ onem(3) = fn3
+ ostride2 = fn1*fn2
+ odist2 = 1
+
+ call dfftw_plan_many_dft(plan_mf2,idim2,nsize1,howmany,B,inem,istride2,idist2,B,onem,ostride2,&
+ &odist2,FFTW_FORWARD,FFTW_ESTIMATE)
+ call dfftw_execute_dft(plan_mf2,B,B)
+ call dfftw_destroy_plan(plan_mf2)
+
+end subroutine forward_transform
+
+
+subroutine backward_transform(n1,n2,n3,fn1,fn2,fn3)
+
+ use transform
+ implicit none
+ integer :: k,j,i
+ integer :: nsize(2),idim,istride,idist,ostride,odist
+ integer :: idim2,istride2,idist2,ostride2,odist2
+ integer :: inem(3),onem(3),howmany,nsize1
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ integer(KIND=8) :: plan_mb1,plan_mb2
+
+
+ idim2 = 1
+ nsize1 = fn3
+ howmany = fn1*fn2
+
+ inem(1) = fn1
+ inem(2) = fn2
+ inem(3) = fn3
+ istride2 = fn1*fn2
+ idist2 = 1
+
+ onem(1) = fn1
+ onem(2) = fn2
+ onem(3) = fn3
+ ostride2 = fn1*fn2
+ odist2 = 1
+
+ call dfftw_plan_many_dft(plan_mb1,idim2,nsize1,howmany,B,inem,istride2,idist2,B,onem,ostride2,&
+ &odist2,FFTW_BACKWARD,FFTW_ESTIMATE)
+ call dfftw_execute_dft(plan_mb1,B,B)
+ call dfftw_destroy_plan(plan_mb1)
+
+ call transpose_backward(n1,n2,n3,fn1,fn2,fn3) !(B,D)
+
+ idim = 2
+ nsize(1) = n1
+ nsize(2) = n2
+ inem(1) = n1
+ inem(2) = n2
+ inem(3) = n3
+ istride = 1
+ idist = n1*n2
+
+ onem(1) = fn1
+ onem(2) = fn3
+ onem(3) = fn2
+ ostride = 1
+ odist = fn1*fn3
+
+ call dfftw_plan_many_dft_c2r(plan_mb2,idim,nsize,fn2,D,onem,ostride,odist,A,inem,istride,idist,FFTW_ESTIMATE)
+ call dfftw_execute_dft_c2r(plan_mb2,D,A)
+ call dfftw_destroy_plan(plan_mb2)
+
+end subroutine backward_transform
+
+
+
+subroutine transpose_forward(n1,n2,n3,fn1,fn2,fn3)
+
+
+
+ use transform
+ implicit none
+
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ integer :: scount,ierr,i,k,ki,jstart,jend,j
+
+ if (nproc.gt.1) then
+
+ scount = fn1*fn2*fn2
+
+
+ do i = 1,nproc
+ do k = 1,fn2
+ ki = (i-1)*fn2 + k
+ jstart = (i-1)*fn2 + 1
+ jend = i*fn2
+
+ C(1:fn1,1:fn2,ki) = D(1:fn1,jstart:jend,k)
+ enddo
+ enddo
+
+
+ call MPI_ALLTOALL(C,scount,MPI_COMPLEX_WP,B,scount,MPI_COMPLEX_WP,MPI_COMM_WORLD,ierr)
+ else
+ do k = 1,fn3
+ do j = 1,fn2
+ do i = 1,fn1
+ B(i,j,k) = D(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+end subroutine transpose_forward
+
+subroutine transpose_backward(n1,n2,n3,fn1,fn2,fn3)
+
+
+
+ use transform
+ implicit none
+
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ integer :: scount,ierr,i,k,ki,jstart,jend,j
+
+ if (nproc.gt.1) then
+
+ scount = fn1*fn2*fn2
+
+
+ call MPI_ALLTOALL(B,scount,MPI_COMPLEX_WP,C,scount,MPI_COMPLEX_WP,MPI_COMM_WORLD,ierr)
+
+
+ do i = 1,nproc
+ do k = 1,fn2
+ ki = (i-1)*fn2 + k
+ jstart = (i-1)*fn2 + 1
+ jend = i*fn2
+ D(1:fn1,jstart:jend,k) = C(1:fn1,1:fn2,ki)
+ enddo
+ enddo
+ else
+ do k = 1,fn3
+ do j = 1,fn2
+ do i = 1,fn1
+ D(i,j,k) = B(i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+
+end subroutine transpose_backward
+
+
+
+
+
+
+
+
+
+
+subroutine transform_init
+
+ use transform
+
+
+
+ implicit none
+
+ integer :: nsize(2),idim,istride,idist,ostride,odist
+ integer :: idim2,istride2,idist2,ostride2,odist2
+ integer :: inem(3),onem(3),howmany
+ integer, parameter :: NULL = 0
+
+ integer :: nsize1
+
+
+! print *,' PLANS', plan_mf1,plan_mf2,plan_mb1,plan_mb2
+
+
+end subroutine transform_init
+
+
+subroutine ftran_wrap(in,out,n1,n2,n3,fn1,fn2,fn3)
+
+ use transform
+ use precision
+ implicit none
+
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ real(WP) :: in(n1,n2,n3)
+ complex(WP) :: out(fn1,fn2,fn3)
+ integer :: i,j,k
+
+ allocate(A(n1,n2,n3))
+ allocate(B(fn1,fn2,fn3))
+ allocate(C(fn1,fn2,fn3))
+ allocate(D(fn1,fn3,fn2))
+
+
+ do k = 1,n3
+ do j = 1,n2
+ do i = 1,n1
+ A(i,j,k) = in(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ call forward_transform(n1,n2,n3,fn1,fn2,fn3)
+
+ do k = 1,fn3
+ do j = 1,fn2
+ do i = 1,fn1
+ out(i,j,k) = B(i,j,k)
+ enddo
+ enddo
+ enddo
+ deallocate(A)
+ deallocate(B)
+ deallocate(C)
+ deallocate(D)
+
+
+end subroutine ftran_wrap
+
+subroutine btran_wrap(in,out,n1,n2,n3,fn1,fn2,fn3)
+
+ use transform
+ use precision
+
+ implicit none
+
+ integer :: n1,n2,n3,fn1,fn2,fn3
+ real(WP) :: out(n1,n2,n3)
+ complex(WP) :: in(fn1,fn2,fn3)
+
+
+ integer :: i,j,k
+
+
+ allocate(A(n1,n2,n3))
+ allocate(B(fn1,fn2,fn3))
+ allocate(C(fn1,fn2,fn3))
+ allocate(D(fn1,fn3,fn2))
+
+
+ do k = 1,fn3
+ do j = 1,fn2
+ do i = 1,fn1
+ B(i,j,k) = in(i,j,k)
+ enddo
+ enddo
+ enddo
+
+
+ call backward_transform(n1,n2,n3,fn1,fn2,fn3)
+
+ do k = 1,n3
+ do j = 1,n2
+ do i = 1,n1
+ out(i,j,k) = A(i,j,k)
+ enddo
+ enddo
+ enddo
+
+ deallocate(A)
+ deallocate(B)
+ deallocate(C)
+ deallocate(D)
+
+
+end subroutine btran_wrap
diff --git a/CodesEnVrac/Remesh/FFTPAR/x_advec.f90 b/CodesEnVrac/Remesh/FFTPAR/x_advec.f90
new file mode 100755
index 0000000000000000000000000000000000000000..27936968063f6072270f00218d492e211358c8c6
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/x_advec.f90
@@ -0,0 +1,296 @@
+module x_advec_m
+
+ use solver
+ use data
+
+ implicit none
+
+ integer :: npart, ntag_total, npg
+ real(WP) :: xmin, ymin, zmin, xmax, ymax, zmax
+ integer, dimension(:), allocatable :: itype
+ real(WP), dimension(:), allocatable :: up
+ real(WP), dimension(:), allocatable :: up_aux
+ real(WP), dimension(:), allocatable :: xp
+ real(WP), dimension(:), allocatable :: xp0
+ real(WP), dimension(:), allocatable :: xp_aux
+ real(WP), dimension(:), allocatable :: vx
+ real(WP), dimension(:), allocatable :: vx_aux
+
+ real(WP) :: circlim
+
+end module x_advec_m
+
+
+
+subroutine x_advec_init
+
+ use x_advec_m
+
+ implicit none
+
+ npg = nxsc !100000
+
+ allocate(up(npg))
+ allocate(up_aux(npg))
+ allocate(xp(npg)) !!-> code original npg = 256 mais ca marche pas
+ allocate(xp0(npg))
+ allocate(xp_aux(npg))
+ allocate(vx(npg))
+ allocate(vx_aux(npg))
+ allocate(itype(npg))
+
+ up = 0.0
+ up_aux = 0.0
+ xp = 0.0
+ xp0 = 0.0
+ xp_aux = 0.0
+ vx = 0.0
+ vx_aux = 0.0
+
+ itype = 0
+
+ npart = 0
+ ntag_total = 0
+
+ xmin = 0.
+ ymin = 0.
+ zmin = 0.
+ xmax = L
+ ymax = L
+ zmax = L
+
+ circlim = 10**(-5)
+
+end subroutine x_advec_init
+
+
+
+subroutine x_advec
+
+ use x_advec_m
+
+ implicit none
+
+ real(WP) :: cfl, dx, yy, zz
+ integer :: i,j,k,np,n, jr, kr
+
+
+ dx = L/nxsc
+ cfl = dt/dx
+
+ print*,"dt =",dt
+
+ npart = 0
+ ntag_total = 0
+
+ do k=1,nxsc
+ zz=xmin+float(k-1)*dx
+ do j=1,nxsc
+ np=0
+ yy=xmin+float(j-1)*dx
+ do i=1,nxsc
+ if (abs(SC(i,j,k)).gt.circlim) then
+ np=np+1
+ up(np)=SC(i,j,k)
+ xp(np)=xmin+float(i-1)*dx
+ up_aux(np)=SC(i,j,k)
+ xp_aux(np)=xmin+float(i-1)*dx
+ end if
+ end do
+ if (np.ne.0) then
+ call velox_x(np,j,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ end do
+ call velox_x(np,j,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ end do
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ end do
+ jr=j
+ kr=k
+ call remeshx(np,jr,kr)
+ npart=npart+np
+ end if
+ end do
+ end do
+
+ print*, 'NPART, NTAG ', npart,ntag_total
+
+end subroutine x_advec
+
+
+
+subroutine velox_x(np,j,k)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np, j, k, i, nx3, ny3, nz3, jp1, jp2, kp1, kp2, ip1, ip2
+ real(WP) :: dx3, dy3, dz3, dxinv, yy, zz, x0, y0, z0, dx2
+ real(WP) :: yy1, yy2, zz1, zz2, b1, b2, c1, c2, a1, a2
+ real(WP) :: x, xx1, xx2
+
+ do i=1,np
+ vx(i)=0.
+ end do
+
+ nx3=nx
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ dx2 = L/nxsc
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2 = 1.0 - yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2 = 1.0 - zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ do i = 1,np
+
+ x = xp(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+
+ a1 = xx2
+ a2 = xx1
+
+ vx(i)= vx(i) + U(ip1,jp1,kp1)*a1*b1*c1
+ vx(i)= vx(i) + U(ip2,jp1,kp1)*a2*b1*c1
+ vx(i)= vx(i) + U(ip1,jp2,kp1)*a1*b2*c1
+ vx(i)= vx(i) + U(ip2,jp2,kp1)*a2*b2*c1
+ vx(i)= vx(i) + U(ip1,jp1,kp2)*a1*b1*c2
+ vx(i)= vx(i) + U(ip2,jp1,kp2)*a2*b1*c2
+ vx(i)= vx(i) + U(ip1,jp2,kp2)*a1*b2*c2
+ vx(i)= vx(i) + U(ip2,jp2,kp2)*a2*b2*c2
+
+ end do
+
+end subroutine velox_x
+
+subroutine remeshx(np1,jj,kk)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np1, jj, kk
+ integer :: i, nx2, n, ip0, ip1, ip2, k, j
+ real(WP) :: dxinv, dx2, x0, g1, x, xx0, xx1, xx2, a0, a1, a2
+
+ nx2 = nxsc
+ dx2 = L/nx2
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ SC(i,jj,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up_aux(n)
+ x = xp_aux(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(ip0,jj,kk) = SC(ip0,jj,kk) + g1*a0
+ SC(ip1,jj,kk) = SC(ip1,jj,kk) + g1*a1
+ SC(ip2,jj,kk) = SC(ip2,jj,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(ip0,jj,kk) = SC(ip0,jj,kk) + g1*a0
+ SC(ip1,jj,kk) = SC(ip1,jj,kk) + g1*a1
+ SC(ip2,jj,kk) = SC(ip2,jj,kk) + g1*a2
+
+ end if
+ end do
+
+!!! go to 222 !! -> ca veut dire quoi goto ?
+!!! do k=3,nx2-2
+!!! do j=1,nx2
+!!! do i=1,nx2
+!!! if (SC(i,j,k).gt.1.2) then
+!!! print*,'BOUM', i,j,k,SC(i,j,k)
+!!! goto 222
+!!! end if
+!!! end do
+!!! end do
+!!! end do
+
+end subroutine remeshx
diff --git a/CodesEnVrac/Remesh/FFTPAR/y_advec.f90 b/CodesEnVrac/Remesh/FFTPAR/y_advec.f90
new file mode 100755
index 0000000000000000000000000000000000000000..b5d20fb7286901e9a2f48640c6caaebcdaa4e9e3
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/y_advec.f90
@@ -0,0 +1,221 @@
+subroutine y_advec
+
+ use x_advec_m
+
+ implicit none
+
+ real(WP) :: cfl, dx, yy, zz
+ integer :: i,j,k,np,n, ir, kr
+
+
+ dx = L/nxsc
+ cfl = dt/dx
+
+ do k=1,nxsc
+ zz=xmin+float(k-1)*dx
+ do i=1,nxsc
+ np=0
+ yy=xmin+float(i-1)*dx
+ do j=1,nxsc
+ if (abs(SC(i,j,k)).gt.circlim) then
+ np=np+1
+! up(np)=SC(i,j,k)
+ xp(np)=xmin+float(j-1)*dx
+ up_aux(np)=SC(i,j,k)
+ xp_aux(np)=xmin+float(j-1)*dx
+ endif
+ enddo
+ if (np.ne.0) then
+ call velox_y(np,i,k)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_y(np,i,k)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ kr=k
+ call remeshy(np,ir,kr)
+ endif
+ enddo
+ enddo
+
+end subroutine y_advec
+
+
+
+subroutine velox_y(np,j,k)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np, j, k, i, nx3, ny3, nz3, jp1, jp2, kp1, kp2, ip1, ip2
+ real(WP) :: dx3, dy3, dz3, dxinv, yy, zz, x0, y0, z0, dx2
+ real(WP) :: yy1, yy2, zz1, zz2, b1, b2, c1, c2, a1, a2
+ real(WP) :: x, xx1, xx2
+
+ do i=1,np
+ vx(i)=0.
+ end do
+
+ nx3=nx
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ dx2 = L/nxsc
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2 = 1.0 - yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2 = 1.0 - zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ do i = 1,np
+
+ x = xp(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+
+ a1 = xx2
+ a2 = xx1
+
+ vx(i)= vx(i) + V(jp1,ip1,kp1)*a1*b1*c1
+ vx(i)= vx(i) + V(jp1,ip2,kp1)*a2*b1*c1
+ vx(i)= vx(i) + V(jp2,ip1,kp1)*a1*b2*c1
+ vx(i)= vx(i) + V(jp2,ip2,kp1)*a2*b2*c1
+ vx(i)= vx(i) + V(jp1,ip1,kp2)*a1*b1*c2
+ vx(i)= vx(i) + V(jp1,ip2,kp2)*a2*b1*c2
+ vx(i)= vx(i) + V(jp2,ip1,kp2)*a1*b2*c2
+ vx(i)= vx(i) + V(jp2,ip2,kp2)*a2*b2*c2
+
+ end do
+
+end subroutine velox_y
+
+subroutine remeshy(np1,jj,kk)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np1, jj, kk
+ integer :: i, nx2, n, ip0, ip1, ip2, k, j
+ real(WP) :: dxinv, dx2, x0, g1, x, xx0, xx1, xx2, a0, a1, a2
+
+ nx2 = nxsc
+ dx2 = L/nx2
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ SC(jj,i,kk)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up_aux(n)
+ x = xp_aux(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(jj,ip0,kk) = SC(jj,ip0,kk) + g1*a0
+ SC(jj,ip1,kk) = SC(jj,ip1,kk) + g1*a1
+ SC(jj,ip2,kk) = SC(jj,ip2,kk) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(jj,ip0,kk) = SC(jj,ip0,kk) + g1*a0
+ SC(jj,ip1,kk) = SC(jj,ip1,kk) + g1*a1
+ SC(jj,ip2,kk) = SC(jj,ip2,kk) + g1*a2
+
+ end if
+ end do
+
+!!! go to 222 !! -> ca veut dire quoi goto ?
+!!! do k=3,nx2-2
+!!! do j=1,nx2
+!!! do i=1,nx2
+!!! if (SC(i,j,k).gt.1.2) then
+!!! print*,'BOUM', i,j,k,SC(i,j,k)
+!!! goto 222
+!!! end if
+!!! end do
+!!! end do
+!!! end do
+
+end subroutine remeshy
diff --git a/CodesEnVrac/Remesh/FFTPAR/z_advec.f90 b/CodesEnVrac/Remesh/FFTPAR/z_advec.f90
new file mode 100755
index 0000000000000000000000000000000000000000..58372178173f1ff40b6c7adb6d033ee713883bef
--- /dev/null
+++ b/CodesEnVrac/Remesh/FFTPAR/z_advec.f90
@@ -0,0 +1,221 @@
+subroutine z_advec
+
+ use x_advec_m
+
+ implicit none
+
+ real(WP) :: cfl, dx, yy, zz
+ integer :: i,j,k,np,n, ir, jr
+
+
+ dx = L/nxsc
+ cfl = dt/dx
+
+ do j=1,nxsc
+ zz=xmin+float(k-1)*dx
+ do i=1,nxsc
+ np=0
+ yy=xmin+float(i-1)*dx
+ do k=1,nxsc
+ if (abs(SC(i,j,k)).gt.circlim) then
+ np=np+1
+! up(np)=SC(i,j,k)
+ xp(np)=xmin+float(k-1)*dx
+ up_aux(np)=SC(i,j,k)
+ xp_aux(np)=xmin+float(k-1)*dx
+ endif
+ enddo
+ if (np.ne.0) then
+ call velox_z(np,i,j)
+ do n=1,np
+ xp0(n)=xp(n)
+ xp(n)=xp(n)+0.5*dt*vx(n)
+ if (xp(n).gt.xmax) xp(n)=xp(n)-xmax+xmin
+ if (xp(n).lt.xmin) xp(n)=xp(n)+xmax-xmin
+ enddo
+ call velox_z(np,i,j)
+ do n=1,np
+ xp_aux(n)=xp0(n)
+ vx_aux(n)=vx(n)
+ itype(n)=1
+ enddo
+ do n=1,np
+ xp_aux(n)=xp_aux(n)+dt*vx_aux(n)
+ if (xp_aux(n).gt.xmax) xp_aux(n)=xp_aux(n)-xmax+xmin
+ if (xp_aux(n).lt.xmin) xp_aux(n)=xp_aux(n)+xmax-xmin
+ enddo
+ ir=i
+ jr=j
+ call remeshz(np,ir,jr)
+ endif
+ enddo
+ enddo
+
+end subroutine z_advec
+
+
+
+subroutine velox_z(np,j,k)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np, j, k, i, nx3, ny3, nz3, jp1, jp2, kp1, kp2, ip1, ip2
+ real(WP) :: dx3, dy3, dz3, dxinv, yy, zz, x0, y0, z0, dx2
+ real(WP) :: yy1, yy2, zz1, zz2, b1, b2, c1, c2, a1, a2
+ real(WP) :: x, xx1, xx2
+
+ do i=1,np
+ vx(i)=0.
+ end do
+
+ nx3=nx
+ ny3=nx3
+ nz3=nx3
+ dx3=xmax/float(nx3)
+ dy3=dx3
+ dz3=dx3
+
+ dxinv=1./dx3
+
+ x0=xmin
+ y0=ymin
+ z0=zmin
+
+ dx2 = L/nxsc
+
+ yy=+float(j-1)*dx2
+ zz=+float(k-1)*dx2
+
+ jp1 = int((yy)/dx3)
+ jp2 = jp1 + 1
+ kp1 = int((zz)/dx3)
+ kp2 = kp1 + 1
+ yy1 = (yy-float(jp1)*dx3)/dx3
+ yy2 = 1.0 - yy1
+ zz1 = (zz-float(kp1)*dx3)/dx3
+ zz2 = 1.0 - zz1
+ b1=yy2
+ b2=yy1
+ c1=zz2
+ c2=zz1
+
+ jp1=mod(jp1+nx3,nx3) +1
+ jp2=mod(jp2+nx3,nx3) +1
+ kp1=mod(kp1+nx3,nx3) +1
+ kp2=mod(kp2+nx3,nx3) +1
+
+ do i = 1,np
+
+ x = xp(i)
+
+ ip1 = int((x-x0)*dxinv)
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx3-x0)*dxinv
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx3,nx3) +1
+ ip2=mod(ip2+nx3,nx3) +1
+
+ a1 = xx2
+ a2 = xx1
+
+ vx(i)= vx(i) + W(jp1,kp1,ip1)*a1*b1*c1
+ vx(i)= vx(i) + W(jp1,kp1,ip2)*a2*b1*c1
+ vx(i)= vx(i) + W(jp2,kp1,ip1)*a1*b2*c1
+ vx(i)= vx(i) + W(jp2,kp1,ip2)*a2*b2*c1
+ vx(i)= vx(i) + W(jp1,kp2,ip1)*a1*b1*c2
+ vx(i)= vx(i) + W(jp1,kp2,ip2)*a2*b1*c2
+ vx(i)= vx(i) + W(jp2,kp2,ip1)*a1*b2*c2
+ vx(i)= vx(i) + W(jp2,kp2,ip2)*a2*b2*c2
+
+ end do
+
+end subroutine velox_z
+
+subroutine remeshz(np1,jj,kk)
+
+ use x_advec_m
+
+ implicit none
+
+ integer :: np1, jj, kk
+ integer :: i, nx2, n, ip0, ip1, ip2, k, j
+ real(WP) :: dxinv, dx2, x0, g1, x, xx0, xx1, xx2, a0, a1, a2
+
+ nx2 = nxsc
+ dx2 = L/nx2
+
+ dxinv=1./dx2
+
+ do i=1,nx2
+ SC(jj,kk,i)=0.
+ enddo
+
+ x0=xmin
+
+ do n = 1,np1
+ g1 = up_aux(n)
+ x = xp_aux(n)
+
+ if (itype(n).eq.0) then
+ ip1 = int((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(jj,kk,ip0) = SC(jj,kk,ip0) + g1*a0
+ SC(jj,kk,ip1) = SC(jj,kk,ip1) + g1*a1
+ SC(jj,kk,ip2) = SC(jj,kk,ip2) + g1*a2
+
+ else
+
+ ip1 = nint((x-x0)*dxinv)
+ ip0 = ip1 - 1
+ ip2 = ip1 + 1
+
+ xx1 = (x - float(ip1)*dx2-x0)*dxinv
+ xx0=xx1+1
+ xx2=1-xx1
+
+ ip1=mod(ip1+nx2,nx2) +1
+ ip0=mod(ip0+nx2,nx2) +1
+ ip2=mod(ip2+nx2,nx2) +1
+
+ a0=-0.5*xx1*xx2
+ a1=1.-xx1**2
+ a2=0.5*xx0*xx1
+
+ SC(jj,kk,ip0) = SC(jj,kk,ip0) + g1*a0
+ SC(jj,kk,ip1) = SC(jj,kk,ip1) + g1*a1
+ SC(jj,kk,ip2) = SC(jj,kk,ip2) + g1*a2
+
+ end if
+ end do
+
+!!! go to 222 !! -> ca veut dire quoi goto ?
+!!! do k=3,nx2-2
+!!! do j=1,nx2
+!!! do i=1,nx2
+!!! if (SC(i,j,k).gt.1.2) then
+!!! print*,'BOUM', i,j,k,SC(i,j,k)
+!!! goto 222
+!!! end if
+!!! end do
+!!! end do
+!!! end do
+
+end subroutine remeshz
diff --git a/CodesEnVrac/Remesh/README b/CodesEnVrac/Remesh/README
new file mode 100644
index 0000000000000000000000000000000000000000..778b7641bf44675708ba0241519e867a1a31b91c
--- /dev/null
+++ b/CodesEnVrac/Remesh/README
@@ -0,0 +1,10 @@
+Codes d'Adrien:
+
+-Advection 2D (formules de remaillage consistantes)
+split_2d
+
+
+-Advection 3D (formules consistantes)
+split_3d_rapide
+
+
diff --git a/Docs/Devel/CodingRules.org b/CodingRules.org
similarity index 100%
rename from Docs/Devel/CodingRules.org
rename to CodingRules.org
diff --git a/Docs/Devel/HowToGrid5000.org b/DevelDocs/HowToGrid5000.org
similarity index 100%
rename from Docs/Devel/HowToGrid5000.org
rename to DevelDocs/HowToGrid5000.org
diff --git a/Docs/Devel/ParmesCD.pdf b/DevelDocs/ParmesCD.pdf
similarity index 100%
rename from Docs/Devel/ParmesCD.pdf
rename to DevelDocs/ParmesCD.pdf
diff --git a/Docs/Devel/about_data_management_on_GPU.tex b/DevelDocs/about_data_management_on_GPU.tex
similarity index 100%
rename from Docs/Devel/about_data_management_on_GPU.tex
rename to DevelDocs/about_data_management_on_GPU.tex
diff --git a/Examples/Attic/NavierStokes3d.py b/Examples/Attic/NavierStokes3d.py
new file mode 100755
index 0000000000000000000000000000000000000000..1531b49ed1f4a3fed954199c80da9748ca4424f1
--- /dev/null
+++ b/Examples/Attic/NavierStokes3d.py
@@ -0,0 +1,188 @@
+#!/usr/bin/python
+import parmepy as pp
+import parmepy.f2py
+import numpy as np
+import mpi4py.MPI as MPI
+import math as m
+
+PARMES_REAL = pp.constants.PARMES_REAL
+ORDER = pp.constants.ORDER
+
+#from numpy import linalg as LA
+
+pi = m.pi
+
+# Import scales and fftw solvers
+ppfft = parmepy.f2py.fftw2py
+scales = parmepy.f2py.scales2py
+
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+# ----------- A 3d problem -----------
+print " ========= Start test for Navier-Stokes 3D ========="
+
+# Physical Domain description
+Lx = Ly = Lz = 2 * pi
+myDomain3d = pp.Box(dimension=3, length=[Lx, Ly, Lz], origin=[0., 0., 0.])
+resolution3d = np.asarray((65, 65, 65))
+ncells = resolution3d - 1
+hx = Lx / ncells[0]
+hy = Ly / ncells[1]
+hz = Lz / ncells[2]
+
+## Obstacle
+lambd = np.array([0, 1, 10 ** 8], dtype=PARMES_REAL, order=ORDER)
+sphere = pp.Obstacle(myDomain3d, name='sphere', zlayer=0.1,
+ radius=0.1, center=[0.5, 0.5, 0.5],
+ orientation='West', porousLayer=0.05)
+
+## Post
+outputFilePrefix = './res/NS_'
+outputModulo = 1
+
+# Simulation parameters
+timeStep = 1e-8
+finalTime = timeStep#1.0
+
+# Fields declaration
+
+# 1 - Poisson/diffusion solvers initialisation.
+# See poisson3d.py for a working example.
+# poisson = pp.Poisson(vorticity,velocity)
+#
+localres, localoffset = ppfft.init_fftw_solver(resolution3d,
+ myDomain3d.length)
+
+print "FFT solver local resolution/offset: ", localres, localoffset
+
+##topofft = poisson.getTopology()
+
+
+def computeVel(x, y, z):
+ vx = 2. / np.sqrt(3) * np.sin(2. * pi / 3.) * np.sin(x) \
+ * np.cos(y) * np.cos(z)
+ vy = 2. / np.sqrt(3) * np.sin(-2. * pi / 3.) * np.cos(x) \
+ * np.sin(y) * np.cos(z)
+ vz = 0.
+ return vx, vy, vz
+
+
+def computeVort(x, y, z):
+ wx = - np.cos(x) * np.sin(y) * np.sin(z)
+ wy = - np.sin(x) * np.cos(y) * np.sin(z)
+ wz = 2. * np.sin(x) * np.sin(y) * np.cos(z)
+ return wx, wy, wz
+
+
+velocity = pp.AnalyticalField(domain=myDomain3d, formula=computeVel,
+ name='Velocity', vector=True)
+vorticity = pp.AnalyticalField(domain=myDomain3d, formula=computeVort,
+ name='Vorticity', vector=True)
+
+############ REF ##############
+x = np.arange(localoffset[0], localres[0] + localoffset[0],
+ dtype='float64') * hx
+y = np.arange(localoffset[1], localres[1] + localoffset[1],
+ dtype='float64') * hy
+z = np.arange(localoffset[2], localres[2] + localoffset[2],
+ dtype='float64') * hz
+
+cden = 4 * pi ** 2 * (Ly ** 2 * Lz ** 2 + Lx ** 2 * Lz ** 2 +
+ Lx ** 2 * Ly ** 2) / (Lx ** 2 * Ly ** 2 * Lz ** 2)
+cx = 2 * pi / Lx
+cy = 2 * pi / Ly
+cz = 2 * pi / Lz
+
+# Initialize vorticity (This init should be improved or done if C or Fortran)
+## for k in range(localres[2]):
+## for j in range(localres[1]):
+## for i in range(localres[0]):
+## omega_x[i, j, k] = cden * (m.sin(cx * x[i]) *
+## m.sin(cy * y[j]) * m.cos(cz * z[k]))
+## omega_y[i, j, k] = cden * (m.cos(cx * x[i]) *
+## m.sin(cy * y[j]) * m.sin(cz * z[k]))
+## omega_z[i, j, k] = cden * (m.cos(cx * x[i]) *
+## m.cos(cy * y[j]) * m.sin(cz * z[k]))
+## ref_x[i, j, k] = -cy * (m.cos(cx * x[i]) * m.sin(cy * y[j])
+## * m.sin(cz * z[k])) - \
+## cz * (m.cos(cx * x[i]) * m.sin(cy * y[j]) * m.cos(cz * z[k]))
+
+## ref_y[i, j, k] = -cz * (m.sin(cx * x[i]) * m.sin(cy * y[j])
+## * m.sin(cz * z[k])) + \
+## cx * (m.sin(cx * x[i]) * m.cos(cy * y[j]) * m.sin(cz * z[k]))
+
+## ref_z[i, j, k] = -cx * (m.sin(cx * x[i]) * m.sin(cy * y[j])
+## * m.sin(cz * z[k])) - \
+## cy * (m.sin(cx * x[i]) * m.cos(cy * y[j]) * m.cos(cz * z[k]))
+
+
+# 2 - Advection solver initialisation. See testScales for a working example.
+# Based on scales JB solver
+# Warning : fields input for scales should be of size (ncells), not localres.
+nbProcs = MPI.COMM_WORLD.Get_size()
+topodims = [1, 1, nbProcs] # fits with fftw topology
+
+scalesres, scalesoffset, stab_coeff = \
+ scales.init_advection_solver(ncells, myDomain3d.length,
+ topodims, order='p_O2')
+
+##topofft = poisson.getTopology()
+##,ghost=2
+topofft = pp.CartesianTopology(domain=myDomain3d,
+ resolution=resolution3d, dim=3)
+
+# 3 - Stretching
+stretch = pp.Stretching(vorticity, velocity)
+
+# 4 - Penalization
+sphere.discretize(topofft)
+sphereD = sphere.discreteObstacle[0]
+penal = pp.Penalization(velocity, vorticity, sphereD, lambd)
+
+# Define the problem to solve
+navierStokes = pp.Problem(topofft, [penal, stretch])
+
+printer = pp.Printer(fields=[vorticity, velocity], frequency=outputModulo,
+ outputPrefix=outputFilePrefix)
+
+navierStokes.setSolver(finalTime, timeStep, solver_type='basic', io=printer)
+
+## Problem => ParticularSover = basic.initialize()
+navierStokes.initSolver()
+
+omega_x = vorticity.discreteField[0][0]
+omega_y = vorticity.discreteField[0][1]
+omega_z = vorticity.discreteField[0][2]
+vx = velocity.discreteField[0][0]
+vy = velocity.discreteField[0][1]
+vz = velocity.discreteField[0][2]
+
+
+## end of init ##
+# Mind that scales works on arrays of size resolution - 1
+# --> pointers to subarrays of velocity/vorticity
+#somega_x = np.zeros((localcells), dtype='float64', order='Fortran')
+# solve advection
+omega_x = scales.solve_advection(timeStep, vx, vy, vz, omega_x)
+omega_y = scales.solve_advection(timeStep, vx, vy, vz, omega_y)
+omega_z = scales.solve_advection(timeStep, vx, vy, vz, omega_z)
+
+# solve stretching
+navierStokes.solve()
+
+print 'vorticity', vorticity.discreteField[0][0] , vorticity.discreteField[0][1] , vorticity.discreteField[0][2]
+
+# solve diffusion
+
+nudt = 0.0001
+omega_x, omega_y, omega_z = \
+ ppfft.solve_diffusion_3d(nudt, vx, vy, vz, omega_x, omega_y, omega_z)
+
+# solve poisson
+vx, vy, vz = ppfft.solve_poisson_3d(omega_x, omega_y, omega_z, vx, vy, vz)
+
+## end of time loop ##
+
+# Clean memory buffers
+ppfft.clean_fftw_solver(myDomain3d.dimension)
diff --git a/Examples/Attic/NavierStokes3d_RMI.py b/Examples/Attic/NavierStokes3d_RMI.py
new file mode 100755
index 0000000000000000000000000000000000000000..e01b076e2de31b78896d046b67059872db7b7f52
--- /dev/null
+++ b/Examples/Attic/NavierStokes3d_RMI.py
@@ -0,0 +1,219 @@
+#!/usr/bin/python
+#import sys
+#sys.path.insert(0,'/scratch/mimeau/install-parmes3/')
+import time
+import parmepy as pp
+from parmepy.f2py import fftw2py
+import mpi4py.MPI as MPI
+import math as m
+from parmepy.constants import np, PARMES_REAL, ORDER
+from parmepy.operator.advection import Advection
+from parmepy.operator.density import DensityVisco
+from parmepy.operator.stretching import Stretching
+from parmepy.operator.diffusion import Diffusion
+from parmepy.operator.poisson import Poisson
+from parmepy.operator.multiphase import Baroclinic
+from parmepy.operator.penalization import Penalization
+from parmepy.operator.redistribute import Redistribute
+from parmepy.problem.navier_stokes import NSProblem
+from parmepy.problem.simulation import Simulation
+from parmepy.operator.monitors.energy_enstrophy import Energy_enstrophy
+from parmepy.operator.monitors.reprojection_criterion import Reprojection_criterion
+from parmepy.operator.monitors.printer import Printer
+from parmepy.dataloader import DataLoader
+
+#from numpy import linalg as LA
+
+pi = m.pi
+
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+## ----------- A 3d problem -----------
+print " ========= Start test for Navier-Stokes 3D (Taylor Green benchmark)========="
+
+## Opening/reading input data file
+data = DataLoader('inputData.dat')
+
+# Parameters
+dim = 3
+nbElem = [data.resX, data.resY, data.resZ]
+nbElemFilter = [data.resFilterX, data.resFilterY, data.resFilterZ]
+densityVal = [data.rho, data.rho2]
+viscoVal = [data.visco, data.visco2]
+
+t0 = time.time()
+
+## Domain
+box = pp.Box(dim, length=[data.Lx, data.Ly, data.Lz],
+ origin=[data.Ox, data.Oy, data.Oz])
+
+## Fields declaration
+def computeVel(x, y, z):
+#--------Richtmyer Meshkov------------
+ vx = data.uinf
+ vy = 0.
+ vz = 0.
+ return vx, vy, vz
+
+def computeVort(x, y, z):
+#--------Richtmyer Meshkov------------
+ wx = 0.
+ wy = 0.
+ wz = (data.uinf * 2.0 * pi / data.Ly) * \
+ m.sin(2.0 * pi * y / data.Ly)
+ return wx, wy, wz
+
+def computeDensity(x, y, z):
+#--------Richtmyer Meshkov------------
+ perturb = 0.2 * np.sin(2.0 * pi * y / 5.9333)
+ d = (3.0 + perturb + 0.5 - x)/(2.0 * 0.5)
+ c = 1.0
+ if d > 0. and d < 1.0 :
+ c = 0.5
+# c = m.exp(-(-m.log10(0.)) * m.fabs(d)^8.0)
+ elif d >= 1.0 :
+ c = 0.
+ rho = densityVal[0] + (densityVal[1] - densityVal[0]) * c
+ return rho
+
+def computeVisco(x, y, z):
+#--------Richtmyer Meshkov------------
+ perturb = 0.2 * np.sin(2.0 * pi * y / 5.9333)
+ d = (3.0 + perturb + 0.5 - x)/(2.0 * 0.5)
+ c = 1.0
+ if d > 0. and d < 1.0 :
+ c = 0.5
+# c = m.exp(-(-m.log10(0.)) * m.fabs(d)^8.0)
+ elif d >= 1.0 :
+ c = 0.
+ nu = viscoVal[0] + (viscoVal[1] - viscoVal[0]) * c
+ return nu
+
+## Fields
+velo = pp.Field(domain=box, formula=computeVel,
+ name='Velocity', isVector=True)
+vorti = pp.Field(domain=box, formula=computeVort,
+ name='Vorticity', isVector=True)
+rho = pp.Field(domain=box, formula=computeDensity,
+ name='Density', isVector=False)
+visco = pp.Field(domain=box, formula=computeVisco,
+ name='Viscosity', isVector=False)
+
+## Operators
+advecVort = Advection(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=data.methodAdv
+ )
+
+stretch = Stretching(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=data.methodStretch,
+ propertyOp=data.propStretch
+ )
+
+diffusion = Diffusion(vorti,
+ resolution=nbElem,
+ method='fftw',
+ viscosity=data.visco
+ )
+
+baroclinic = Baroclinic(velo, vorti, rho, visco,
+ resolutions={velo: nbElem,
+ vorti: nbElem,
+ rho: nbElem,
+ visco: nbElem},
+ method=data.methodBaro
+ )
+
+advecScalar = Advection(velo, rho,
+ resolutions={velo: nbElem,
+ rho: nbElem},
+ method=data.methodAdvSc
+ )
+
+density = DensityVisco(rho, visco,
+ resolutions={rho: nbElem,
+ visco: nbElem},
+ method='',
+ densityVal = densityVal,
+ viscoVal = viscoVal
+ )
+
+poisson = Poisson(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method='fftw',
+ projection=data.vortProj,
+ multires=data.multires,
+ filterSize=box.length / \
+ (np.asarray(nbElemFilter,
+ dtype=PARMES_REAL) - 1)
+ )
+
+## Diagnostics related to the problem
+energy = Energy_enstrophy(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ viscosity=data.visco,
+ frequency=data.outModuloEnergies,
+ prefix='./res/Energies_test.dat')
+
+#reproj = Reprojection_criterion(velo, vorti,
+# resolutions={velo: nbElem,
+# vorti: nbElem},
+# method='FD_order4',
+# frequency=1,
+# prefix='../res/Reproj.dat')
+
+printer = Printer(fields=[rho],
+ frequency=data.outModuloPrinter,
+ prefix=data.outputPrinter,
+ ext='.vtk'
+ )
+
+distrAdvStr = Redistribute([vorti, velo], advecVort, stretch)
+distrStrDiff = Redistribute([vorti], stretch, diffusion)
+distrDiffBaro = Redistribute([vorti], diffusion, baroclinic)
+distrBaroPoiss = Redistribute([vorti], baroclinic, poisson)
+distrDensBaro = Redistribute([rho, visco], density, baroclinic)
+
+## Definition of simulation parameters
+simu = Simulation(tinit=0.0, tend=data.finalTime, timeStep=data.timeStep, iterMax=1000000)
+
+## Define the problem to solve
+#pb = NSProblem([advecVort, stretch, diffusion, baroclinic, advecScalar, density, poisson],
+pb = NSProblem(operators=[advecVort, distrAdvStr, stretch, distrStrDiff, diffusion,
+ distrDiffBaro, baroclinic, distrBaroPoiss, advecScalar,
+ density, poisson, distrDensBaro],
+#pb = NSProblem(operators=[advecVort, distrAdvStr, stretch, distrStrDiff, diffusion,
+# advecScalar, density, poisson],
+ simulation=simu,
+ monitors=[energy],
+ dumpFreq=int(data.dumpfreq), name=data.dumpfile)
+## Setting solver to Problem
+pb.setUp()
+
+## Restarting Problem from dumped field values
+if data.restart :
+ pb.restart(data.dumpfile)
+
+t1 = time.time()
+
+## Solve problem
+#poisson.apply(simu)
+timings = pb.solve()
+
+tf = time.time()
+
+print "\n"
+print "Total time : ", tf - t0, "sec (CPU)"
+print "Init time : ", t1 - t0, "sec (CPU)"
+print "Solving time : ", tf - t1, "sec (CPU)"
+
+## end of time loop ##
+
+# Clean memory buffers
+fftw2py.clean_fftw_solver(box.dimension)
diff --git a/Examples/Attic/NavierStokes3d_penal.py b/Examples/Attic/NavierStokes3d_penal.py
new file mode 100755
index 0000000000000000000000000000000000000000..f21e2a16743ec0581bf56867fd9b5334f24f5e5d
--- /dev/null
+++ b/Examples/Attic/NavierStokes3d_penal.py
@@ -0,0 +1,285 @@
+#!/usr/bin/python
+import time
+import parmepy as pp
+import parmepy.f2py
+import numpy as np
+import mpi4py.MPI as MPI
+import math as m
+from parmepy.constants import PARMES_REAL, ORDER
+from parmepy.domain.obstacle.obstacle_3D import Obstacle3D
+from parmepy.operator.advection import Advection
+from parmepy.operator.stretching import Stretching
+from parmepy.operator.poisson import Poisson
+from parmepy.operator.diffusion import Diffusion
+from parmepy.operator.penalization import Penalization
+from parmepy.operator.redistribute import Redistribute
+from parmepy.problem.navier_stokes import NSProblem
+from parmepy.operator.monitors.energy_enstrophy import Energy_enstrophy
+from parmepy.operator.monitors.printer import Printer
+from parmepy.operator.monitors.compute_forces import Compute_forces
+
+#from numpy import linalg as LA
+
+pi = m.pi
+
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+## ----------- A 3d problem -----------
+print " ========= Start test for penalized Navier-Stokes 3D ========="
+
+## Opening/reading input data file
+inputData = open("input.dat", "r")
+
+Ox = np.float64(inputData.readline().rstrip('\n\r'))
+Oy = np.float64(inputData.readline().rstrip('\n\r'))
+Oz = np.float64(inputData.readline().rstrip('\n\r'))
+Lx = np.float64(inputData.readline().rstrip('\n\r'))
+Ly = np.float64(inputData.readline().rstrip('\n\r'))
+Lz = np.float64(inputData.readline().rstrip('\n\r'))
+resX = np.uint32(inputData.readline().rstrip('\n\r'))
+resY = np.uint32(inputData.readline().rstrip('\n\r'))
+resZ = np.uint32(inputData.readline().rstrip('\n\r'))
+timeStep = np.float64(inputData.readline().rstrip('\n\r'))
+finalTime = np.float64(inputData.readline().rstrip('\n\r'))
+outModuloPrinter = np.uint32(inputData.readline().rstrip('\n\r'))
+outputPrinter = inputData.readline().rstrip('\n\r')
+outModuloForces = np.uint32(inputData.readline().rstrip('\n\r'))
+outputForces = inputData.readline().rstrip('\n\r')
+outModuloEnergies = np.uint32(inputData.readline().rstrip('\n\r'))
+outputEnergies = inputData.readline().rstrip('\n\r')
+visco = np.float64(inputData.readline().rstrip('\n\r'))
+vortProj = np.uint32(inputData.readline().rstrip('\n\r'))
+methodAdv = inputData.readline().rstrip('\n\r')
+methodStretch = inputData.readline().rstrip('\n\r')
+methodPenal = inputData.readline().rstrip('\n\r')
+methodForces = inputData.readline().rstrip('\n\r')
+uinf = np.float64(inputData.readline().rstrip('\n\r'))
+obstName = inputData.readline().rstrip('\n\r')
+lambdFluid = np.float64(inputData.readline().rstrip('\n\r'))
+lambdPorous = np.float64(inputData.readline().rstrip('\n\r'))
+lambdSolid = np.float64(inputData.readline().rstrip('\n\r'))
+obstRadius = np.float64(inputData.readline().rstrip('\n\r'))
+obstOx = np.float64(inputData.readline().rstrip('\n\r'))
+obstOy = np.float64(inputData.readline().rstrip('\n\r'))
+obstOz = np.float64(inputData.readline().rstrip('\n\r'))
+obstOrientation = inputData.readline().rstrip('\n\r')
+thicknPorous = np.float64(inputData.readline().rstrip('\n\r'))
+thicknZbound = np.float64(inputData.readline().rstrip('\n\r'))
+
+inputData.close()
+
+# Parameters
+dim = 3
+nbElem = [resX, resY, resZ]
+
+t0 = time.time()
+
+## Domain
+box = pp.Box(dim, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+## Obstacle
+lambd = np.array([lambdSolid, lambdPorous],
+ dtype=PARMES_REAL, order=ORDER)
+sphere = Obstacle3D(box,
+ center=[obstOx, obstOy, obstOz],
+ zlayer=thicknZbound,
+ porousLayerThickn=thicknPorous,
+ porousLayerConfig='',
+ obstacleName=obstName,
+ radius=obstRadius)
+
+## Fields declaration
+def computeVel(x, y, z):
+# vx = 2. / np.sqrt(3) * np.sin(2. * pi / 3.) * np.sin(x) \
+# * np.cos(y) * np.cos(z)
+# vy = 2. / np.sqrt(3) * np.sin(-2. * pi / 3.) * np.cos(x) \
+# * np.sin(y) * np.cos(z)
+# vz = 0.
+#----------- flow past sphere ----------
+ vx = 0.
+ module = (x - obstOx) ** 2 + (y - obstOy) ** 2 + (z - obstOz) ** 2
+ if (module >= obstRadius ** 2):
+ vx = uinf * (1 - (obstRadius ** 2 / module))
+ vy = 0.
+ vz = 0.
+# # --------Taylor Green------------
+# vx = np.sin(x) * np.cos(y) * np.cos(z)
+# vy = - np.cos(x) * np.sin(y) * np.cos(z)
+# vz = 0.
+#-----------------
+# vx = 0.
+# vy = 0.
+# vz = 0.
+ return vx, vy, vz
+
+
+def computeVort(x, y, z):
+# wx = - np.cos(x) * np.sin(y) * np.sin(z)
+# wy = - np.sin(x) * np.cos(y) * np.sin(z)
+# wz = 2. * np.sin(x) * np.sin(y) * np.cos(z)
+#----------- flow past sphere ----------
+ wx = 0.
+ wy = 0.
+ wz = 0.
+# module = (x - obstOx) ** 2 + (y - obstOy) ** 2 + (z - obstOz) ** 2
+# if (module >= obstRadius ** 2):
+# wy = (2.0 * uinf * obstRadius ** 2 * (z - obstOz)) / module ** 2
+# wz = -(2.0 * uinf * obstRadius ** 2 * (y - obstOy)) / module ** 2
+# # --------Taylor Green------------
+# wx = - np.cos(x) * np.sin(y) * np.sin(z)
+# wy = - np.sin(x) * np.cos(y) * np.sin(z)
+# wz = 2. * np.sin(x) * np.sin(y) * np.cos(z)
+#-----------------
+# xc = 6./2.
+# yc = 6./2.
+# zc = 6./6.
+# R = 1.5
+# sigma = R / 3.
+# Gamma = 0.0075
+# dist = m.sqrt((x-xc)**2 + (y-yc)**2)
+# s2 = (z - zc)**2 + (dist - R)**2
+# wx = 0.
+# wy = 0.
+# wz = 0.
+# if (dist != 0.):
+# cosTheta = (x-xc) / dist
+# sinTheta = (y-yc) / dist
+# wTheta = Gamma / (pi * sigma**2) * m.exp(-(s2 / sigma**2))
+# wx = - wTheta * sinTheta
+# wy = wTheta * cosTheta
+# wz = 0.
+ return wx, wy, wz
+
+def computeVortNorm(x, y, z):
+ norm = 0.
+#----------------
+# xc = 6./2.
+# yc = 6./2.
+# zc = 6./6.
+# R = 1.5
+# sigma = R / 3.
+# Gamma = 0.0075
+# dist = m.sqrt((x-xc)**2 + (y-yc)**2)
+# s2 = (z - zc)**2 + (dist - R)**2
+# norm = 0.
+# if (dist != 0.):
+# cosTheta = (x-xc) / dist
+# sinTheta = (y-yc) / dist
+# wTheta = Gamma / (pi * sigma**2) * m.exp(-(s2 / sigma**2))
+# wx = - wTheta * sinTheta
+# wy = wTheta * cosTheta
+# wz = 0.
+# norm = np.sqrt(wx ** 2 + wy ** 2 + wz ** 2)
+ return norm
+
+#def computeDensity(x, y, z):
+# if (x>=0):
+# rho = 1000.
+# else :
+# rho = 1.
+# return rho
+
+
+## Fields
+velo = pp.Field(domain=box, formula=computeVel,
+ name='Velocity', isVector=True)
+vorti = pp.Field(domain=box, formula=computeVort,
+ name='Vorticity', isVector=True)
+#vortNorm = pp.Field(domain=box, formula=computeVortNorm,
+# name='VortNorm', isVector=False)
+#density = pp.Field(domain=box, formula=computeDensity,
+# name='Density', isVector=False)
+
+## Operators
+advec = Advection(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=methodAdv
+ )
+
+stretch = Stretching(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=methodStretch,
+ propertyOp='divConservation'
+ )
+
+diffusion = Diffusion(vorti,
+ resolution=nbElem,
+ method='fftw',
+ viscosity=visco
+ )
+
+poisson = Poisson(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method='fftw',
+ projection=False
+ )
+
+penal = Penalization(velo, vorti, sphere, lambd,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=methodPenal,
+ with_curl=True
+ )
+
+## Diagnostics related to the problem
+forces = Compute_forces(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ penal=penal,
+ boxMin=[Ox + Lx / 10., Oy + Ly / 10., Oz + Lz / 10.],
+ boxMax=[Lx - Lx / 10., Ly - Ly / 10., Lz - Lz / 10.],
+ Reynolds=uinf * obstRadius/ visco,
+ method=methodForces,
+ frequency=outModuloForces,
+ outputPrefix=outputForces)
+
+energy = Energy_enstrophy(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ viscosity=visco,
+ frequency=outModuloEnergies,
+ outputPrefix=outputEnergies)
+
+printer = Printer(fields=[vorti, velo],
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ frequency=outModuloPrinter,
+ outputPrefix=outputPrinter)
+
+distrAdvStr = Redistribute([vorti, velo], advec, stretch)
+distrStrPoiss = Redistribute([vorti, velo], stretch, poisson)
+distrPoissPen = Redistribute([vorti, velo], poisson, penal)
+distrPenAdv = Redistribute([vorti, velo], penal, advec)
+
+## Define the problem to solve
+#pb = NSProblem([advec, distrAdvPen, penal, distrPenAdv],
+# monitors=[energy, printer])
+pb = NSProblem([advec, distrAdvStr, stretch, distrStrPoiss,
+ diffusion, poisson, distrPoissPen, penal, distrPenAdv],
+ monitors=[energy, printer])
+
+## Setting solver to Problem
+pb.setUp(finalTime, timeStep)
+
+t1 = time.time()
+
+## Solve problem
+penal.apply(0., timeStep, 0)
+distrPenAdv.apply(0., timeStep, 0)
+timings = pb.solve()
+
+tf = time.time()
+
+print "\n"
+print "Total time : ", tf - t0, "sec (CPU)"
+print "Init time : ", t1 - t0, "sec (CPU)"
+print "Solving time : ", tf - t1, "sec (CPU)"
+
+## end of time loop ##
+
+# Clean memory buffers
+fftw2py.clean_fftw_solver(box.dimension)
diff --git a/Examples/Attic/NavierStokes3d_sphere.py b/Examples/Attic/NavierStokes3d_sphere.py
new file mode 100755
index 0000000000000000000000000000000000000000..ca7ca59e8c3c4767e09d5004c106a3af05b323c3
--- /dev/null
+++ b/Examples/Attic/NavierStokes3d_sphere.py
@@ -0,0 +1,278 @@
+#!/usr/bin/python
+import parmepy as pp
+import parmepy.f2py
+import numpy as np
+import mpi4py.MPI as MPI
+import math as m
+from parmepy.obstacle.obstacle import Obstacle
+from parmepy.operator.advec_scales import Advec_scales
+from parmepy.operator.stretching import Stretching
+from parmepy.operator.poisson import Poisson
+from parmepy.operator.diffusion import Diffusion
+from parmepy.operator.penalization import Penalization
+from parmepy.tools.timer import Timer
+from parmepy.tools.printer import Printer
+from parmepy.tools.compute_forces import Compute_forces
+from parmepy.tools.energy_enstrophy import Energy_enstrophy
+
+PARMES_REAL = pp.constants.PARMES_REAL
+ORDER = pp.constants.ORDER
+
+#from numpy import linalg as LA
+
+pi = m.pi
+
+## Import scales and fftw solvers
+ppfft = parmepy.f2py.fftw2py
+scales = parmepy.f2py.scales2py
+
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+## ----------- A 3d problem -----------
+print " ========= Start test for Navier-Stokes 3D ========="
+
+## Opening/reading input data file
+inputData = open("input.dat", "r")
+
+Ox = np.float64(inputData.readline().rstrip('\n\r'))
+Oy = np.float64(inputData.readline().rstrip('\n\r'))
+Oz = np.float64(inputData.readline().rstrip('\n\r'))
+Lx = np.float64(inputData.readline().rstrip('\n\r'))
+Ly = np.float64(inputData.readline().rstrip('\n\r'))
+Lz = np.float64(inputData.readline().rstrip('\n\r'))
+resX = np.uint32(inputData.readline().rstrip('\n\r'))
+resY = np.uint32(inputData.readline().rstrip('\n\r'))
+resZ = np.uint32(inputData.readline().rstrip('\n\r'))
+timeStep = np.float64(inputData.readline().rstrip('\n\r'))
+finalTime = np.float64(inputData.readline().rstrip('\n\r'))
+outModuloPrinter = np.uint32(inputData.readline().rstrip('\n\r'))
+outputPrinter = inputData.readline().rstrip('\n\r')
+outModuloForces = np.uint32(inputData.readline().rstrip('\n\r'))
+outputForces = inputData.readline().rstrip('\n\r')
+outModuloEnergies = np.uint32(inputData.readline().rstrip('\n\r'))
+outputEnergies = inputData.readline().rstrip('\n\r')
+nbGhosts = np.uint32(inputData.readline().rstrip('\n\r'))
+visco = np.float64(inputData.readline().rstrip('\n\r'))
+uinf = np.float64(inputData.readline().rstrip('\n\r'))
+obstName = inputData.readline().rstrip('\n\r')
+lambdFluid = np.float64(inputData.readline().rstrip('\n\r'))
+lambdPorous = np.float64(inputData.readline().rstrip('\n\r'))
+lambdSolid = np.float64(inputData.readline().rstrip('\n\r'))
+obstRadius = np.float64(inputData.readline().rstrip('\n\r'))
+obstOx = np.float64(inputData.readline().rstrip('\n\r'))
+obstOy = np.float64(inputData.readline().rstrip('\n\r'))
+obstOz = np.float64(inputData.readline().rstrip('\n\r'))
+obstOrientation = inputData.readline().rstrip('\n\r')
+thicknPorous = np.float64(inputData.readline().rstrip('\n\r'))
+thicknZbound = np.float64(inputData.readline().rstrip('\n\r'))
+
+inputData.close()
+
+## Physical Domain description
+myDomain3d = pp.Box(dimension=3, length=[Lx, Ly, Lz], origin=[Ox, Oy, Oz])
+resolution3d = np.asarray((resX, resY, resZ))
+ncells = resolution3d - 1
+hx = Lx / ncells[0]
+hy = Ly / ncells[1]
+hz = Lz / ncells[2]
+
+## Obstacle
+lambd = np.array([lambdSolid, lambdPorous],
+ dtype=PARMES_REAL, order=ORDER)
+sphere = Obstacle(myDomain3d,
+ name=obstName,
+ zlayer=thicknZbound,
+ radius=obstRadius,
+ center=[obstOx, obstOy, obstOz],
+ orientation=obstOrientation,
+ porousLayer=thicknPorous)
+
+### Post
+#outputFilePrefix = './res/NS_'
+#outputModulo = 50
+
+### Simulation parameters
+#timeStep = 1.#1e-1
+#finalTime = 10000.#20.*timeStep
+
+
+## Topologies definitions
+# 1---- FFT topology + diffusion/poisson solvers initialization -----------
+localres, localoffset = ppfft.init_fftw_solver(resolution3d,
+ myDomain3d.length)
+print "FFT solver local resolution/offset: ", localres, localoffset
+##topofft = poisson.getTopology()
+
+# ---- Cartesian topology -----
+topoCart = pp.Cartesian(domain=myDomain3d,
+ dim=3,
+ globalMeshResolution=resolution3d,
+ ghosts=[nbGhosts,nbGhosts,nbGhosts])
+
+# ---- JB's topology ----------
+nbProcs = MPI.COMM_WORLD.Get_size()
+topodims = [1, 1, nbProcs] # fits with fftw topology
+
+
+## Fields declaration
+def computeVel(x, y, z):
+# vx = 2. / np.sqrt(3) * np.sin(2. * pi / 3.) * np.sin(x) \
+# * np.cos(y) * np.cos(z)
+# vy = 2. / np.sqrt(3) * np.sin(-2. * pi / 3.) * np.cos(x) \
+# * np.sin(y) * np.cos(z)
+# vz = 0.
+#------------------
+ vx = 0.
+ module = (x-obstOx)**2 + (y-obstOy)**2 + (z-obstOz)**2
+ if (module >= obstRadius**2):
+ vx = uinf * (1-(obstRadius**2/module))
+ vy = 0.
+ vz = 0.
+#-----------------
+# vx = 0.
+# vy = 0.
+# vz = 0.
+ return vx, vy, vz
+
+
+def computeVort(x, y, z):
+# wx = - np.cos(x) * np.sin(y) * np.sin(z)
+# wy = - np.sin(x) * np.cos(y) * np.sin(z)
+# wz = 2. * np.sin(x) * np.sin(y) * np.cos(z)
+#-----------------
+ wx = 0.
+ wy = 0.
+ wz = 0.
+#-----------------
+# xc = 6./2.
+# yc = 6./2.
+# zc = 6./6.
+# R = 1.5
+# sigma = R / 3.
+# Gamma = 0.0075
+# dist = m.sqrt((x-xc)**2 + (y-yc)**2)
+# s2 = (z - zc)**2 + (dist - R)**2
+# wx = 0.
+# wy = 0.
+# wz = 0.
+# if (dist != 0.):
+# cosTheta = (x-xc) / dist
+# sinTheta = (y-yc) / dist
+# wTheta = Gamma / (pi * sigma**2) * m.exp(-(s2 / sigma**2))
+# wx = - wTheta * sinTheta
+# wy = wTheta * cosTheta
+# wz = 0.
+ return wx, wy, wz
+
+def computeVortNorm(x, y, z):
+ norm = 0.
+#----------------
+# xc = 6./2.
+# yc = 6./2.
+# zc = 6./6.
+# R = 1.5
+# sigma = R / 3.
+# Gamma = 0.0075
+# dist = m.sqrt((x-xc)**2 + (y-yc)**2)
+# s2 = (z - zc)**2 + (dist - R)**2
+# norm = 0.
+# if (dist != 0.):
+# cosTheta = (x-xc) / dist
+# sinTheta = (y-yc) / dist
+# wTheta = Gamma / (pi * sigma**2) * m.exp(-(s2 / sigma**2))
+# wx = - wTheta * sinTheta
+# wy = wTheta * cosTheta
+# wz = 0.
+# norm = np.sqrt(wx ** 2 + wy ** 2 + wz ** 2)
+ return norm
+
+#def computeDensity(x, y, z):
+# if (x>=0):
+# rho = 1000.
+# else :
+# rho = 1.
+# return rho
+
+velocity = pp.AnalyticalField(domain=myDomain3d, formula=computeVel,
+ name='Velocity', vector=True)
+vorticity = pp.AnalyticalField(domain=myDomain3d, formula=computeVort,
+ name='Vorticity', vector=True)
+vortNorm = pp.AnalyticalField(domain=myDomain3d, formula=computeVortNorm,
+ name='VortNorm', vector=False)
+#density = pp.AnalyticalField(domain=myDomain3d, formula=computeDensity,
+# name='Density', vector=False)
+
+
+
+## 2 - Advection solver initialization. See testScales for a working example.
+# Based on scales JB solver
+# Warning : fields input for scales should be of size (ncells), not localres.
+
+scalesres, scalesoffset, stab_coeff = \
+ scales.init_advection_solver(ncells, myDomain3d.length,
+ topodims, order='p_O2')
+
+print 'advection stability coeff', stab_coeff
+advecVort = Advec_scales(stab_coeff, velocity, vorticity, vortNorm)
+#advecDensity = Advec_scales(stab_coeff, velocity, density)
+
+# ----> Change TOPO from Scales to Cartesian
+
+## 3 - Stretching
+stretch = Stretching(velocity, vorticity)
+
+# ----> Change TOPO from Cartesian to FFT
+
+## 4 - Diffusion
+diffusion = Diffusion(velocity, vorticity, viscosity=visco)
+
+## 4 - Poisson
+poisson = Poisson(velocity, vorticity)
+
+# ----> Change TOPO from FFT to Cartesian
+
+## 6 - Penalization
+penal = Penalization(velocity, vorticity, sphere, lambd)
+
+# ----> Change TOPO from Cartesian to Scales
+
+## Define the problem to solve
+navierStokes = pp.Problem(topoCart, [advecVort, stretch, diffusion, poisson, penal])
+#navierStokes = pp.Problem(topoCart, [advecVort, stretch, poisson])
+
+## Set solver and Define the diagnostics related to the problem
+printer = Printer(fields=[vorticity, velocity, vortNorm], frequency=outModuloPrinter,
+ outputPrefix=outputPrinter)
+
+#forces = Compute_forces(velocity=velocity, vorticity=vorticity,
+# topology=topoCart,
+# obstacle=sphere,
+# boxMin=[Ox + Lx / 10., Oy + Ly / 10., Oz + Lz / 10.],
+# boxMax=[Lx - Lx / 10., Ly - Ly / 10., Lz - Lz / 10.],
+# Reynolds=uinf * obstRadius/ visco,
+# frequency=outModuloForces,
+# outputPrefix=outputForces)
+
+energy = Energy_enstrophy(velocity=velocity, vorticity=vorticity,
+ topology=topoCart,
+ frequency=outModuloEnergies,
+ outputPrefix=outputEnergies)
+
+navierStokes.addDiagnostics([energy])
+
+navierStokes.setSolver(finalTime, timeStep, solver_type='basic', io=printer)
+
+## Initialize problem
+navierStokes.initSolver()
+
+penal.apply(0., timeStep)
+#poisson.apply(0., timeStep)
+
+## Solve problem
+navierStokes.solve()
+
+## End of time loop ##
+
+## Clean memory buffers
+ppfft.clean_fftw_solver(myDomain3d.dimension)
diff --git a/Examples/Attic/NavierStokes3d_vortRing.py b/Examples/Attic/NavierStokes3d_vortRing.py
new file mode 100755
index 0000000000000000000000000000000000000000..c609bf47d8312a3f0c9814660bfc5ea72b45d6e0
--- /dev/null
+++ b/Examples/Attic/NavierStokes3d_vortRing.py
@@ -0,0 +1,233 @@
+#!/usr/bin/python
+#import sys
+#sys.path.insert(0,'/scratch/mimeau/install-parmes3/')
+import time
+import parmepy as pp
+from parmepy.f2py import fftw2py
+import numpy as np
+import mpi4py.MPI as MPI
+import math as m
+from parmepy.constants import PARMES_REAL, ORDER
+from parmepy.operator.advection import Advection
+from parmepy.operator.stretching import Stretching
+from parmepy.operator.poisson import Poisson
+from parmepy.operator.diffusion import Diffusion
+from parmepy.operator.penalization import Penalization
+from parmepy.operator.redistribute import Redistribute
+from parmepy.problem.navier_stokes import NSProblem
+from parmepy.problem.simulation import Simulation
+from parmepy.operator.monitors.energy_enstrophy import Energy_enstrophy
+from parmepy.operator.monitors.reprojection_criterion import Reprojection_criterion
+from parmepy.operator.monitors.printer import Printer
+from parmepy.dataloader import DataLoader
+
+
+#from numpy import linalg as LA
+
+pi = m.pi
+
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+## ----------- A 3d problem -----------
+print " ========= Start test for Navier-Stokes 3D (Taylor Green benchmark)========="
+
+## Opening/reading input data file
+data = DataLoader('inputData_TG.dat')
+
+#inputData = open("input.dat", "r")
+
+#Ox = np.float64(inputData.readline().rstrip('\n\r'))
+#Oy = np.float64(inputData.readline().rstrip('\n\r'))
+#Oz = np.float64(inputData.readline().rstrip('\n\r'))
+#Lx = np.float64(inputData.readline().rstrip('\n\r'))
+#Ly = np.float64(inputData.readline().rstrip('\n\r'))
+#Lz = np.float64(inputData.readline().rstrip('\n\r'))
+#resX = np.uint32(inputData.readline().rstrip('\n\r'))
+#resY = np.uint32(inputData.readline().rstrip('\n\r'))
+#resZ = np.uint32(inputData.readline().rstrip('\n\r'))
+#dt = np.float64(inputData.readline().rstrip('\n\r'))
+#finalTime = np.float64(inputData.readline().rstrip('\n\r'))
+#restart = np.uint32(inputData.readline().rstrip('\n\r'))
+#dumpfreq = np.uint32(inputData.readline().rstrip('\n\r'))
+#dumpfile = inputData.readline().rstrip('\n\r')
+#outModuloPrinter = np.uint32(inputData.readline().rstrip('\n\r'))
+#outputPrinter = inputData.readline().rstrip('\n\r')
+#outModuloForces = np.uint32(inputData.readline().rstrip('\n\r'))
+#outputForces = inputData.readline().rstrip('\n\r')
+#outModuloEnergies = np.uint32(inputData.readline().rstrip('\n\r'))
+#outputEnergies = inputData.readline().rstrip('\n\r')
+#visco = np.float64(inputData.readline().rstrip('\n\r'))
+#vortProj = np.uint32(inputData.readline().rstrip('\n\r'))
+#methodAdv = inputData.readline().rstrip('\n\r')
+#methodStretch = inputData.readline().rstrip('\n\r')
+#multires = np.uint32(inputData.readline().rstrip('\n\r'))
+#resFilterX = np.uint32(inputData.readline().rstrip('\n\r'))
+#resFilterY = np.uint32(inputData.readline().rstrip('\n\r'))
+#resFilterZ = np.uint32(inputData.readline().rstrip('\n\r'))
+
+#inputData.close()
+
+# Parameters
+dim = 3
+nbElem = [data.resX, data.resY, data.resZ]
+nbElemFilter = [data.resFilterX, data.resFilterY, data.resFilterZ]
+
+t0 = time.time()
+
+## Domain
+box = pp.Box(dim, length=[2.0 * pi, 2.0 * pi, 2.0 * pi],
+ origin=[data.Ox, data.Oy, data.Oz])
+
+## Fields declaration
+def computeVel(x, y, z):
+# # --------Vorticity ring----------
+# vx = 0.
+# vy = 0.
+# vz = 0.
+# # --------Taylor Green------------
+ vx = np.sin(x) * np.cos(y) * np.cos(z)
+ vy = - np.cos(x) * np.sin(y) * np.cos(z)
+ vz = 0.
+ return vx, vy, vz
+
+def computeVort(x, y, z):
+ # --------Vorticity ring----------
+# xc = 6. / 2.
+# yc = 6. / 2.
+# zc = 6. / 6.
+# R = 1.5
+# sigma = R / 3.
+# Gamma = 0.75
+# dist = m.sqrt((x - xc) ** 2 + (y - yc) ** 2)
+# s2 = (z - zc) ** 2 + (dist - R) ** 2
+# wx = 0.
+# wy = 0.
+# wz = 0.
+# if (dist != 0.):
+# cosTheta = (x - xc) / dist
+# sinTheta = (y - yc) / dist
+# wTheta = Gamma / (pi * sigma ** 2) * m.exp(-(s2 / sigma ** 2))
+# wx = - wTheta * sinTheta
+# wy = wTheta * cosTheta
+# wz = 0.
+# # --------Taylor Green------------
+ wx = - np.cos(x) * np.sin(y) * np.sin(z)
+ wy = - np.sin(x) * np.cos(y) * np.sin(z)
+ wz = 2. * np.sin(x) * np.sin(y) * np.cos(z)
+ return wx, wy, wz
+
+def computeVortNorm(x, y, z):
+ xc = 6. / 2.
+ yc = 6. / 2.
+ zc = 6. / 6.
+ R = 1.5
+ sigma = R / 3.
+ Gamma = 7.5
+ dist = m.sqrt((x - xc) ** 2 + (y - yc) ** 2)
+ s2 = (z - zc) ** 2 + (dist - R) ** 2
+ norm = 0.
+ if (dist != 0.):
+ cosTheta = (x - xc) / dist
+ sinTheta = (y - yc) / dist
+ wTheta = Gamma / (pi * sigma ** 2) * m.exp(-(s2 / sigma ** 2))
+ wx = - wTheta * sinTheta
+ wy = wTheta * cosTheta
+ wz = 0.
+ norm = np.sqrt(wx ** 2 + wy ** 2 + wz ** 2)
+ return norm
+
+## Fields
+velo = pp.Field(domain=box, formula=computeVel,
+ name='Velocity', isVector=True)
+vorti = pp.Field(domain=box, formula=computeVort,
+ name='Vorticity', isVector=True)
+#vortNorm = pp.Field(domain=box, formula=computeVortNorm,
+# name='VortNorm', isVector=False)
+
+## Operators
+advec = Advection(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=data.methodAdv
+ )
+
+stretch = Stretching(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method=data.methodStretch,
+ propertyOp=data.propStretch,
+ )
+
+diffusion = Diffusion(vorti,
+ resolution=nbElem,
+ method='fftw',
+ viscosity=data.visco
+ )
+
+poisson = Poisson(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method='fftw',
+ projection=data.vortProj,
+ multires=data.multires,
+ filterSize=box.length / \
+ (np.asarray(nbElemFilter,
+ dtype=PARMES_REAL) - 1)
+ )
+
+## Diagnostics related to the problem
+energy = Energy_enstrophy(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ viscosity=data.visco,
+ frequency=data.outModuloEnergies,
+ prefix=data.outputEnergies)
+
+reproj = Reprojection_criterion(velo, vorti,
+ resolutions={velo: nbElem,
+ vorti: nbElem},
+ method='FD_order4',
+ frequency=1,
+ prefix='./Reproj.dat')
+
+printer = Printer(fields=[vorti, velo],
+ frequency=data.outModuloPrinter,
+ prefix=data.outputPrinter,
+ ext='.vtk')
+
+distrAdvStr = Redistribute([vorti, velo], advec, stretch)
+distrStrPoiss = Redistribute([vorti, velo], stretch, poisson)
+
+## Definition of simulation parameters
+simu = Simulation(tinit=0.0, tend=data.finalTime, timeStep=data.timeStep, iterMax=1000000)
+
+## Define the problem to solve
+#pb = NSProblem([diffusion, poisson],
+pb = NSProblem(operators=[advec, distrAdvStr, stretch, distrStrPoiss, diffusion, poisson],
+ simulation=simu, monitors=[printer, energy, reproj],
+ dumpFreq=int(data.dumpfreq), name=data.dumpfile)
+## Setting solver to Problem
+pb.setUp()
+
+## Restarting Problem from dumped field values
+if data.restart :
+ pb.restart(data.dumpfile)
+
+t1 = time.time()
+
+## Solve problem
+#poisson.apply(simu)
+timings = pb.solve()
+
+tf = time.time()
+
+print "\n"
+print "Total time : ", tf - t0, "sec (CPU)"
+print "Init time : ", t1 - t0, "sec (CPU)"
+print "Solving time : ", tf - t1, "sec (CPU)"
+
+## end of time loop ##
+
+# Clean memory buffers
+fftw2py.clean_fftw_solver(box.dimension)
diff --git a/Examples/Attic/driver3D.py b/Examples/Attic/driver3D.py
new file mode 100755
index 0000000000000000000000000000000000000000..48b642abbb0b0d35f2c3194a7c9ca4721b3b31e5
--- /dev/null
+++ b/Examples/Attic/driver3D.py
@@ -0,0 +1,61 @@
+import parmepy as pp
+import numpy as np
+import mpi4py.MPI as MPI
+import math
+import parmepy.f2py
+
+pi = math.pi
+ppfft = parmepy.f2py.fftw2py
+
+# Start MPI and get informations
+rank = MPI.COMM_WORLD.Get_rank()
+print "Mpi process number ", rank
+
+# Physical Domain description (geometry and boundary conditions)
+myDomain = pp.Box(dimension=3,length=[1.,1.,1.],origin=[0.,-0.5,-0.5])
+
+# Continuous fields declaration
+scalar = pp.ContinuousField(domain=myDomain,name="scalar3D")
+velocity = pp.ContinuousField(domain=myDomain,name="velocity3D")
+vorticity = pp.ContinuousField(domain=myDomain,name="vorticity3D")
+
+# Build operators/problems
+poisson = pp.Poisson(vorticity,velocity)
+
+# Set and initialize a solving method for this problem
+poisson.setSolvingMethod("fftw-cpu")
+# Set one (or more) global resolution.
+globalResolution = [65,65,65]
+poisson.initialize_solver(globalResolution) # ---> call localRes,localOffset = ppfft.init_poisson_solver(globalResolution,myDomain.length)
+# this will create a topology, a local discretisation for vel and vort and will allocate memory for those fields
+
+# initialize data
+vorticity.discretize(topoFFT)
+
+# Solve ...
+
+poisson.solve() ## call velx,vely,velz = ppfft.solve_poisson_3d(omx,omy,omz)
+
+
+
+
+
+# Build some mpi topologies on the current domain
+
+#topo3D = pp.CartesianTopology(domain=myDomain,resolution=globalResolution,dim=3)
+
+#resol2D = [1, 12, 12]
+#topo2D = pp.CartesianTopology(domain=myDomain,resolution=resol2D,dims=[1,2])
+# Discretize a field on these topologies
+#scalar.discretize(topo3D)
+#scalD,idScalD = scalar.discretize(topo2D)
+
+#print scalar
+
+#print scalD
+
+#velocity.discretize(topo3D)
+
+## scalarD.tofile("toto")
+
+## print velo
diff --git a/Examples/Attic/gaussianSheared.cl b/Examples/Attic/gaussianSheared.cl
new file mode 100644
index 0000000000000000000000000000000000000000..c2c1b25c509d6871f6b5f7a99b2ddffe0d5dbee4
--- /dev/null
+++ b/Examples/Attic/gaussianSheared.cl
@@ -0,0 +1,36 @@
+__kernel void initScalar(__global float* scalar,
+ float4 minPos,
+ float4 size)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint i;
+ float r;
+ float2 pos;
+ for(i=gidX; i<WIDTH; i+=WGN)
+ {
+ pos = (float2)(i*size.x + minPos.x, gidY*size.y + minPos.x);
+ r = length(pos);
+ scalar[i+gidY*(WIDTH)] = ((r<1.0f) ? pown(1.0f - r*r,6) : 0.0f);
+ }
+}
+
+
+__kernel void initVelocity(__global float* veloX,__global float* veloY,
+ float4 minPos,
+ float4 size)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint i;
+ float v,r;
+ float2 pos;
+ for(i=gidX; i<WIDTH; i+=WGN)
+ {
+ pos = (float2)(i*size.x + minPos.x, gidY*size.y + minPos.x);
+ r = length(pos);
+ v = pos.y*cos(3.0f*M_PI_2_F*r);
+ veloX[i+gidY*(WIDTH)] = -v; // = Vx(x,y)
+ veloY[i+gidY*(WIDTH)] = v;// = Vy(y,x) = -Vx(x,y)
+ }
+}
diff --git a/Examples/Attic/gaussianSheared.py b/Examples/Attic/gaussianSheared.py
new file mode 100644
index 0000000000000000000000000000000000000000..095e304a0a06efdf5cccf16b6a1ca500aca12926
--- /dev/null
+++ b/Examples/Attic/gaussianSheared.py
@@ -0,0 +1,75 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+import math
+
+
+def vitesse(x):
+ r = math.sqrt(x[0] * x[0] + x[1] * x[1])
+ c = math.cos(3 * math.pi * r / 2.)
+ return [-c * x[1], c * x[0]]
+
+
+def scalaire(x):
+ r = math.sqrt(x[0] * x[0] + x[1] * x[1])
+ if r < 1:
+ return (1. - r * r) ** 6
+ else:
+ return 0.
+
+
+def run():
+ dim = 2
+ nb = 256
+ boxLength = [2., 2.]
+ boxMin = [-1., -1.]
+ nbElem = [nb, nb]
+
+ timeStep = 0.02
+ finalTime = 2*timeStep
+ outputFilePrefix = './res/gaussianSheared_results_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(dim, length=boxLength, origin=boxMin)
+
+ ## Fields
+ scal = pp.ContinuousField(domain=box, name='Scalar')
+ velo = pp.ContinuousField(domain=box, name='Velocity', vector=True)
+ #scal = pp.AnalyticalField(domain=box, formula=scalaire, name='Scalar')
+ #velo = pp.AnalyticalField(domain=box, formula=vitesse, name='Velocity', vector=True)
+
+ ## Operators
+ advec = pp.Transport(velo, scal)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=nbElem, dim=dim)
+
+ ##Problem
+ pb = pp.Problem(topo3D, [advec])
+
+ ## Setting solver to Problem
+ pb.setSolver(finalTime, timeStep, 'gpu',
+ src=['./gaussianSheared.cl'],
+ io=pp.Printer(fields=[scal, velo], frequency=outputModulo, outputPrefix=outputFilePrefix))
+ pb.initSolver()
+
+ t1 = time.time()
+
+ ## Solve problem
+ pb.solve()
+
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Attic/input.dat b/Examples/Attic/input.dat
new file mode 100644
index 0000000000000000000000000000000000000000..a7812513c9948c084f0cf9bf2a8d2223c6f12f3a
--- /dev/null
+++ b/Examples/Attic/input.dat
@@ -0,0 +1,42 @@
+0.0
+0.0
+0.0
+6.28318531
+6.28318531
+6.28318531
+257
+257
+257
+0.01
+10.0
+1
+4000000
+./res/restart
+8000000
+./res/TG_
+1
+./res/NocaForces.dat
+1
+./res/Energies_256_noproj_nomultires.dat
+0.000625
+0
+scales_p_M6
+FD_order4 RK3
+0
+129
+129
+129
+FD_order4
+FD_order4
+1.0
+sphere
+0.
+10.
+10E8
+0.1
+0.3
+0.5
+0.5
+West
+0.
+0.001
diff --git a/Examples/Attic/inputData.dat b/Examples/Attic/inputData.dat
new file mode 100644
index 0000000000000000000000000000000000000000..fd60ee84a872c479a1155688ce2acd4a7017dfbc
--- /dev/null
+++ b/Examples/Attic/inputData.dat
@@ -0,0 +1,54 @@
+#--------- DOMAIN -----------
+Origin X = 0.0
+Origin Y = 0.0
+Origin Z = 0.0
+Lenght X = 9.3
+Lenght Y = 9.3
+Lenght Z = 9.3
+Resolution X (nbs points) = 33
+Resolution Y (nbs points) = 33
+Resolution Z (nbs points) = 33
+#---------- TIME ------------
+Time Step = 0.01
+Final Time = 10.0
+Restart = 0
+#-------- OUTPUTS -----------
+Frequency of Saving = 4000000
+File to restart = ../res/restart
+Frequency of Visualisation = 8000000
+Output file for visualisation = ../res/TG_
+Frequency of Forces output = 1
+Output file for Forces = ../res/NocaForces.dat
+Frequency of Energy output = 1
+Output file for Energy = ../res/Energies_test.dat
+#--------- FLOW -------------
+Upstream velocity = 1.0
+Density = 784.6
+Viscosity = 0.000316
+Dens2 = 1880
+Visco2 = 0.0000142
+#------- NUM METHODS --------
+Advection Method = scales_p_M6
+Scalar Advec Method = scales_p_M6
+Stretching Method = FD_order4 RK3
+Stretching Property = massConservation
+Baro Method = FD_order4
+Penalisation Method = FD_order4
+Forces Method = FD_order4
+#----- PROJ & MULTIRES ------
+Vorticity projection = 0
+Multi resolution = 0
+Resolution Filter X = 129
+Resolution Filter Y = 129
+Resolution Filter Z = 129
+#------ PENALIZATION --------
+Name of Obstacle = sphere
+Lambda Fluid = 0.
+Lambda Porous = 10.
+Lambda Solid = 10E8
+Obstacle Radius = 0.1
+Obstacle origin in X = 0.3
+Obstacle origin in Y = 0.5
+Obstacle origin in Z = 0.5
+Thickness of Porous layer = 0.
+Size of Bound in Z direction = 0.001
diff --git a/Examples/Attic/inputData_TG.dat b/Examples/Attic/inputData_TG.dat
new file mode 100644
index 0000000000000000000000000000000000000000..f36df6a2e918efc0ec07e3bd65fad7c46ff2c1e8
--- /dev/null
+++ b/Examples/Attic/inputData_TG.dat
@@ -0,0 +1,34 @@
+#--------- DOMAIN -----------
+Origin X = 0.0
+Origin Y = 0.0
+Origin Z = 0.0
+Lenght X = 6.28318531
+Lenght Y = 6.28318531
+Lenght Z = 6.28318531
+Resolution X (nbs points) = 33
+Resolution Y (nbs points) = 33
+Resolution Z (nbs points) = 33
+#---------- TIME ------------
+Time Step = 0.01
+Final Time = 10.0
+Restart = 0
+#-------- OUTPUTS -----------
+Frequency of Saving = 4000000
+File to restart = ../res/restart
+Frequency of Visualisation = 8000000
+Output file for visualisation = ../res/TG_
+Frequency of Energy output = 1
+Output file for Energy = ../res/Energies_test.dat
+#--------- FLOW -------------
+Upstream velocity = 1.0
+Viscosity = 0.000625
+#------- NUM METHODS --------
+Advection Method = scales_p_M6
+Stretching Method = FD_order4 RK3
+Stretching Property = divConservation
+#----- PROJ & MULTIRES ------
+Vorticity projection = 1
+Multi resolution = 0
+Resolution Filter X = 129
+Resolution Filter Y = 129
+Resolution Filter Z = 129
diff --git a/Examples/Attic/mainED.py b/Examples/Attic/mainED.py
new file mode 100755
index 0000000000000000000000000000000000000000..21e3fcdf56856fa50f8cc34c81b54643905095d2
--- /dev/null
+++ b/Examples/Attic/mainED.py
@@ -0,0 +1,79 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+from math import *
+
+
+def vitesse(x, y, z):
+ vx = 1. + x
+ vy = - x * y
+ vz = x * y * z + 10.
+ return vx, vy, vz
+
+def vorticite(x, y, z):
+ wx = x * y
+ wy = y * z
+ wz = - y
+ return wx, wy, wz
+
+def scalaire(x, y, z):
+ if x < 0.5 and y < 0.5 and z < 0.5:
+ return 1.
+ else:
+ return 0.
+
+
+def run():
+ # Parameters
+ nb = 32
+ timeStep = 0.02
+ finalTime = 1.
+ outputFilePrefix = './res/Stretching_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Fields
+ #scal = pp.ContinuousField(domain=box, name='Scalar')
+ #velo = pp.ContinuousField(domain=box, name='Velocity', vector=True)
+ #vorti = pp.ContinuousField(domain=box, name='Vorticity', vector=True)
+ #scal = pp.AnalyticalField(domain=box, name='Scalar')
+ velo = pp.AnalyticalField(domain=box, formula=vitesse, name='Velocity', vector=True)
+ vorti = pp.AnalyticalField(domain=box, formula=vorticite, name='Vorticity', vector=True)
+
+ ## Operators
+ #advec = pp.Transport(velo, scal)
+ stretch = pp.Stretching(velo,vorti)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3)
+
+ ##Problem
+ #pb = pp.Problem(topo3D, [advec,stretch])
+ pb = pp.Problem(topo3D, [stretch])
+
+ ## Setting solver to Problem
+ ## Problem => ParticularSover = basic.init()
+ pb.setSolver(finalTime, timeStep, solver_type='basic',
+ io=pp.Printer(fields=[vorti, velo], frequency=outputModulo, outputPrefix=outputFilePrefix))
+ ## Problem => ParticularSover = basic.initialize()
+ pb.initSolver()
+
+ t1 = time.time()
+
+ ## Solve problem
+ pb.solve()
+
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Attic/main_Rotating_2D.py b/Examples/Attic/main_Rotating_2D.py
new file mode 100644
index 0000000000000000000000000000000000000000..20b9b6e304adc00e8cf01f8c813f36523ae22a4f
--- /dev/null
+++ b/Examples/Attic/main_Rotating_2D.py
@@ -0,0 +1,70 @@
+# -*- coding: utf-8 -*-
+import time
+import new_ParMePy as pp
+import math
+
+
+def vitesse(x):
+ return [- x[1] * 2 * math.acos(-1), x[0] * 2 * math.acos(-1)]
+
+
+def scalaire(x):
+ rr = math.sqrt(x[0] * x[0] + (x[1] - 0.5) * (x[1] - 0.5))
+ if rr < 0.25:
+ return (1. - rr * rr / 0.0625) ** 4
+ else:
+ return 0.
+
+
+def run():
+ dim = 2
+ nb = 1024
+ boxLength = [2., 2.]
+ boxMin = [-1., -1.]
+ nbElem = [nb, nb]
+
+ timeStep = 0.07
+ FinalTime = 1.
+ outputFilePrefix = './res/RK2_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ box = pp.Domain.Box(dimension=dim,
+ length=boxLength,
+ minPosition=boxMin)
+ velo = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=dim,
+ formula=vitesse)
+ scal = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=1,
+ formula=scalaire, scalar=True)
+ advec = pp.Operator.Advection(velo, scal)
+ cTspPb = pp.Problem.ContinuousTransportProblem(advection=advec)
+
+ cTspPb.discretize(dSpec=[nbElem])
+
+ InterpolationMethod = pp.Utils.Linear(grid=box.discreteDomain, gvalues=velo.discreteVariable)
+ RemeshingMethod = pp.Utils.M6Prime(grid=box.discreteDomain, gvalues=scal.discreteVariable)
+ ODESolver = pp.Utils.RK2(InterpolationMethod, box.discreteDomain.applyConditions)
+ ## cpu
+ #solver = pp.Utils.ParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod)
+ ## gpu
+ #solver = pp.GPUParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu')
+ solver = pp.GPUParticularSolver_GLRender(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu', dt=timeStep)
+ cTspPb.setSolver(solver)
+ cTspPb.setPrinter(pp.Utils.Printer(frequency=outputModulo, outputPrefix=outputFilePrefix, problem=cTspPb))
+
+ t1 = time.time()
+
+ cTspPb.solve(T=FinalTime, dt=timeStep)
+
+ tf = time.time()
+
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Attic/main_Rotating_2D_GH.py b/Examples/Attic/main_Rotating_2D_GH.py
new file mode 100644
index 0000000000000000000000000000000000000000..7b8801bdc1f35538e82702f3e749decd7b1a50d6
--- /dev/null
+++ b/Examples/Attic/main_Rotating_2D_GH.py
@@ -0,0 +1,81 @@
+# -*- coding: utf-8 -*-
+import time
+import new_ParMePy as pp
+import math
+
+
+# def vitesse(x):
+# return [-math.sin(x[0] * math.pi) ** 2 * math.sin(x[1] * math.pi * 2),
+# math.sin(x[1] * math.pi) ** 2 * math.sin(x[0] * math.pi * 2)]
+# #vx(i)=-sin(pix)*sin(pix)*sin(pi2y)*amodul
+# #vy(i)=+sin(pi2x)*sin(piy)*sin(piy)*amodul
+
+
+# def scalaire(x):
+# rr = math.sqrt((x[0] - 0.5) ** 2 + (x[1] - 0.75) ** 2)
+# if rr < 0.15:
+# return 1.
+# else:
+# return 0.
+
+
+def run():
+ dim = 2
+ nb = 1024
+ boxLength = [1., 1.]
+ boxMin = [0., 0.]
+ nbElem = [nb, nb]
+
+ timeStep = 0.07
+ period = 10.
+ FinalTime = period
+ outputFilePrefix = './res/RK2_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ box = pp.Domain.Box(dimension=dim,
+ length=boxLength,
+ minPosition=boxMin)
+ velo = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=dim, name="Velocity"
+ )
+ scal = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=1,
+ scalar=True, name="Scalar"
+ )
+ advec = pp.Operator.Advection(velo, scal)
+ cTspPb = pp.Problem.ContinuousTransportProblem(advection=advec)
+ cTspPb.addOperator(pp.Operator.VelocityOp(velo, period=period), 0)
+
+ cTspPb.discretize(dSpec=[nbElem])
+
+ InterpolationMethod = pp.Utils.Linear(grid=box.discreteDomain, gvalues=velo.discreteVariable)
+ RemeshingMethod = pp.Utils.M6Prime(grid=box.discreteDomain, gvalues=scal.discreteVariable)
+ ODESolver = pp.Utils.RK2(InterpolationMethod, box.discreteDomain.applyConditions)
+ ## cpu
+ #solver = pp.Utils.ParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod)
+ ## gpu
+ #solver = pp.GPUParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu')
+ solver = pp.GPUParticularSolver_GLRender(cTspPb,
+ ODESolver, InterpolationMethod, RemeshingMethod,
+ device_type='gpu', dt=timeStep,
+ src='./examples/main_Rotating_2D_GH_kernels.cl',
+ endTime=FinalTime
+ )
+ cTspPb.setSolver(solver)
+ cTspPb.setPrinter(pp.Utils.Printer(frequency=outputModulo, outputPrefix=outputFilePrefix, problem=cTspPb))
+
+ t1 = time.time()
+
+ cTspPb.solve(T=FinalTime, dt=timeStep)
+
+ tf = time.time()
+
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Attic/main_Rotating_2D_GH_kernels.cl b/Examples/Attic/main_Rotating_2D_GH_kernels.cl
new file mode 100644
index 0000000000000000000000000000000000000000..6232abf622b6cdd30f67cf8aef0e04747133ac07
--- /dev/null
+++ b/Examples/Attic/main_Rotating_2D_GH_kernels.cl
@@ -0,0 +1,51 @@
+
+__kernel void initScalar(__global float* values,
+ __private const float t,
+ __private const float4 min,
+ __private const uint4 nb,
+ __private const float4 size)
+{
+ __private uint ind,ix,iy;
+ __private float px,py,s;
+
+ ix = get_global_id(0);
+ iy = get_global_id(1);
+
+ px = min.x + (float)(ix)*size.x;
+ py = min.y + (float)(iy)*size.y;
+
+ if (sqrt((px-0.5f)*(px-0.5f) + (py-0.75f)*(py-0.75f)) < 0.15f)
+ s = 1.0f;
+ else
+ s = 0.0f;
+ // Write
+ ind = iy + ix*nb.y;
+ values[ind] = s;
+}
+
+// velocity field
+__kernel void velocity(__global float* gvelo,
+ __private const float t,
+ __private const float period,
+ __private const float4 min,
+ __private const uint4 nb,
+ __private const float4 size
+ )
+{
+ __private uint ix,iy, ind;
+ __private float px,py,vx,vy;
+
+ ix = get_global_id(0);
+ iy = get_global_id(1);
+
+ px = min.x + (float)(ix)*size.x; //2flop
+ py = min.y + (float)(iy)*size.y; //2flop
+
+ vx = -sin(px*M_PI_F)*sin(px*M_PI_F)*sin(2.0f*py*M_PI_F)*cos(t*M_PI_F/period); // 14flop
+ vy = sin(py*M_PI_F)*sin(py*M_PI_F)*sin(2.0f*px*M_PI_F)*cos(t*M_PI_F/period); // 14flop
+
+ ind = iy + ix*nb.y;
+ gvelo[ind] = vx;
+ ind = nb.x*nb.y + ix + iy*nb.x;
+ gvelo[ind] = vy;
+}
diff --git a/Examples/Attic/main_Rotating_3D_GH.py b/Examples/Attic/main_Rotating_3D_GH.py
new file mode 100644
index 0000000000000000000000000000000000000000..731d99cd6e0f6a4b18efdf8e2241e7c657e4d1e2
--- /dev/null
+++ b/Examples/Attic/main_Rotating_3D_GH.py
@@ -0,0 +1,65 @@
+# -*- coding: utf-8 -*-
+import time
+import new_ParMePy as pp
+import math
+
+
+def run():
+ dim = 3
+ nb = 160
+ boxLength = [1., 1., 1.]
+ boxMin = [0., 0., 0.]
+ nbElem = [nb, nb, nb]
+
+ timeStep = 0.07
+ period = 3.
+ FinalTime = period
+ outputFilePrefix = './res/RK2_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ box = pp.Domain.Box(dimension=dim,
+ length=boxLength,
+ minPosition=boxMin)
+ velo = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=dim, name="Velocity"
+ )
+ scal = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=1,
+ scalar=True, name="Scalar"
+ )
+ advec = pp.Operator.Advection(velo, scal)
+ cTspPb = pp.Problem.ContinuousTransportProblem(advection=advec)
+ cTspPb.addOperator(pp.Operator.VelocityOp(velo, period=period), 0)
+
+ cTspPb.discretize(dSpec=[nbElem])
+
+ InterpolationMethod = pp.Utils.Linear(grid=box.discreteDomain, gvalues=velo.discreteVariable)
+ RemeshingMethod = pp.Utils.M6Prime(grid=box.discreteDomain, gvalues=scal.discreteVariable)
+ ODESolver = pp.Utils.RK2(InterpolationMethod, box.discreteDomain.applyConditions)
+ ## cpu
+ #solver = pp.Utils.ParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod)
+ ## gpu
+ #solver = pp.GPUParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu')
+ solver = pp.GPUParticularSolver_GLRender(cTspPb,
+ ODESolver, InterpolationMethod, RemeshingMethod,
+ device_type='gpu', dt=timeStep,
+ src='./examples/main_Rotating_3D_GH_kernels.cl'
+ )
+ cTspPb.setSolver(solver)
+ cTspPb.setPrinter(pp.Utils.Printer(frequency=outputModulo, outputPrefix=outputFilePrefix, problem=cTspPb))
+
+ t1 = time.time()
+
+ cTspPb.solve(T=FinalTime, dt=timeStep)
+
+ tf = time.time()
+
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Attic/main_Rotating_3D_GH_kernels.cl b/Examples/Attic/main_Rotating_3D_GH_kernels.cl
new file mode 100644
index 0000000000000000000000000000000000000000..60446e2840e537374ba683465de477cd8efcf996
--- /dev/null
+++ b/Examples/Attic/main_Rotating_3D_GH_kernels.cl
@@ -0,0 +1,58 @@
+
+__kernel void initScalar(__global float* values,
+ __private const float t,
+ __private const float4 min,
+ __private const uint4 nb,
+ __private const float4 size)
+{
+ __private uint ind,ix,iy,iz;
+ __private float px,py,pz,s;
+
+ ix = get_global_id(0);
+ iy = get_global_id(1);
+ iz = get_global_id(2);
+
+ px = min.x + (float)(ix)*size.x;
+ py = min.y + (float)(iy)*size.y;
+ pz = min.z + (float)(iz)*size.z;
+
+ if (sqrt((px-0.35f)*(px-0.35f) + (py-0.35f)*(py-0.35f) + (pz-0.35f)*(pz-0.35f)) < 0.15f)
+ s = 1.0f;
+ else
+ s = 0.0f;
+ // Write
+ ind = iz + iy*nb.z + ix*nb.y*nb.z;
+ values[ind] = s;
+}
+
+// velocity field
+__kernel void velocity(__global float* gvelo,
+ __private const float t,
+ __private const float period,
+ __private const float4 min,
+ __private const uint4 nb,
+ __private const float4 size
+ )
+{
+ __private uint ix,iy, iz, ind;
+ __private float px,py, pz,vx,vy,vz;
+
+ ix = get_global_id(0);
+ iy = get_global_id(1);
+ iz = get_global_id(2);
+
+ px = min.x + (float)(ix)*size.x;
+ py = min.y + (float)(iy)*size.y;
+ pz = min.z + (float)(iz)*size.z;
+
+ vx = 2.0f * sin(px*M_PI_F)*sin(px*M_PI_F)*sin(2.0f*py*M_PI_F)*sin(2.0f*pz*M_PI_F)*cos(t*M_PI_F/period);
+ vy = -sin(2.0f*px*M_PI_F)*sin(py*M_PI_F)*sin(py*M_PI_F)*sin(2.0f*pz*M_PI_F)*cos(t*M_PI_F/period);
+ vz = -sin(2.0f*px*M_PI_F)*sin(pz*M_PI_F)*sin(pz*M_PI_F)*sin(2.0f*py*M_PI_F)*cos(t*M_PI_F/period);
+
+ ind = iz + iy*nb.z + ix*nb.y*nb.z;
+ gvelo[ind] = vx;
+ ind = (nb.x*nb.y*nb.z) + iz + ix*nb.z + iy*nb.x*nb.z;
+ gvelo[ind] = vy;
+ ind = (nb.x*nb.y*nb.z)*2 + iy + ix*nb.y + iz*nb.x*nb.y;
+ gvelo[ind] = vz;
+}
diff --git a/Examples/Attic/main_Shear_2D.py b/Examples/Attic/main_Shear_2D.py
new file mode 100644
index 0000000000000000000000000000000000000000..dd1ac45cfb4a563cd5015adfe04a043e5dcec46e
--- /dev/null
+++ b/Examples/Attic/main_Shear_2D.py
@@ -0,0 +1,72 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+import math
+
+
+def vitesse(x):
+ r = math.sqrt(x[0] * x[0] + x[1] * x[1])
+ c = math.cos(3 * math.pi * r / 2.)
+ return [-c * x[1], c * x[0]]
+
+
+def scalaire(x):
+ r = math.sqrt(x[0] * x[0] + x[1] * x[1])
+ if r < 1:
+ return (1. - r * r) ** 6
+ else:
+ return 0.
+
+
+def run():
+ dim = 2
+ nb = 128
+ boxLength = [2., 2.]
+ boxMin = [-1., -1.]
+ nbElem = [nb, nb]
+
+ timeStep = 0.02
+ FinalTime = 1.
+ outputFilePrefix = './res/RK2_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ box = pp.Domain.Box(dimension=dim,
+ length=boxLength,
+ minPosition=boxMin)
+ velo = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=dim,
+ formula=vitesse)
+ scal = pp.Variable.AnalyticalVariable(domain=box,
+ dimension=1,
+ formula=scalaire, scalar=True)
+ advec = pp.Operator.Advection(velo, scal)
+ cTspPb = pp.Problem.ContinuousTransportProblem(advection=advec)
+
+ cTspPb.discretize(dSpec=[nbElem])
+
+ InterpolationMethod = pp.Utils.Linear(grid=box.discreteDomain, gvalues=velo.discreteVariable)
+ RemeshingMethod = pp.Utils.M6Prime(grid=box.discreteDomain, gvalues=scal.discreteVariable)
+ ODESolver = pp.Utils.RK2(InterpolationMethod, box.discreteDomain.applyConditions)
+ ## cpu
+ #solver = pp.Utils.ParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod)
+ ## gpu
+ #solver = pp.GPUParticularSolver(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu')
+ solver = pp.GPUParticularSolver_GLRender(cTspPb, ODESolver, InterpolationMethod, RemeshingMethod, device_type='gpu', dt=timeStep)
+ cTspPb.setSolver(solver)
+ cTspPb.setPrinter(pp.Utils.Printer(frequency=outputModulo, outputPrefix=outputFilePrefix, problem=cTspPb))
+
+ t1 = time.time()
+
+ cTspPb.solve(T=FinalTime, dt=timeStep)
+
+ tf = time.time()
+
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/Examples/Froggy/MPI_HelloWorld.py b/Examples/Froggy/MPI_HelloWorld.py
new file mode 100644
index 0000000000000000000000000000000000000000..132730df72705f903bbce72eac38fdd02464b968
--- /dev/null
+++ b/Examples/Froggy/MPI_HelloWorld.py
@@ -0,0 +1,9 @@
+import mpi4py.MPI as mpi
+comm = mpi.COMM_WORLD
+rank = comm.Get_rank()
+size = comm.Get_size()
+name = mpi.Get_processor_name()
+
+print (str(name) + ' :: Rank:' + str(rank) + ' (Total='+ str(size) + ')')
+
+
diff --git a/Examples/Froggy/launcher.sh b/Examples/Froggy/launcher.sh
new file mode 100755
index 0000000000000000000000000000000000000000..4027391f5ccdbb5f346264b9a060fd69c9641e30
--- /dev/null
+++ b/Examples/Froggy/launcher.sh
@@ -0,0 +1,8 @@
+#!/bin/bash
+## Oarscript demo launcher
+
+# Basic demo
+oarsub -l/nodes=2/core=3,walltime=00:30:00 --project parmes -n TEST_BASIC -S ./oarscript_basic.sh
+
+# GPU demo (no need of GPU nodes for the HelloWorld, otherwise it requires the oarsub option: -t gpu)
+oarsub -l/nodes=2/core=3,walltime=00:30:00 --project parmes -n TEST_GPU -S ./oarscript_gpu.sh
\ No newline at end of file
diff --git a/Examples/Froggy/oarscript_basic.sh b/Examples/Froggy/oarscript_basic.sh
new file mode 100755
index 0000000000000000000000000000000000000000..946e351c1491dce5670ce12b49f54dd99da39693
--- /dev/null
+++ b/Examples/Froggy/oarscript_basic.sh
@@ -0,0 +1,23 @@
+#!/bin/bash
+#OAR -n JOBNAME
+
+# Source the Froggy environment file
+source /home/$USER/Code/Parmes/Froggy_Env.sh
+
+# Export the prefix for our custom mpirun
+export MPIPREFIX="/home/perignon/install-gnu-4.8"
+
+# Set a current directory variable
+# Each job is associated with a scratch dir : /scratch/$USER/oar.$OAR_JOB_ID. This directory is erased at the job end.
+# A manual directory in the scratch is not erased: /scratch/$USER/toto
+CURRENT_DIR="/home/$USER/Code/Examples/Froggy_Tools/"
+cd $CURRENT_DIR
+
+# Compute the proper core number for the OAR_NODE_FILE.
+# It results in a run on all cores requested in the oarsub command.
+nbcores=`cat $OAR_NODE_FILE|wc -l`
+
+# The mpirun command.
+# OAR_NODE_FILE is given as a openmpi machinefile.
+# One must forward the 3 environment variables : PATH, PYTHONPATH and LD_LIBRARY_PATH
+mpirun --machinefile $OAR_NODE_FILE --prefix $MPIPREFIX -x PYTHONPATH -x PATH -x LD_LIBRARY_PATH -np $nbcores python $CURRENT_DIR'MPI_HelloWorld.py'
diff --git a/Examples/Froggy/oarscript_gpu.sh b/Examples/Froggy/oarscript_gpu.sh
new file mode 100755
index 0000000000000000000000000000000000000000..3241dce7cfe084431bd81a5bfc2ac161ac749175
--- /dev/null
+++ b/Examples/Froggy/oarscript_gpu.sh
@@ -0,0 +1,26 @@
+#!/bin/bash
+#OAR -n JOBNAME
+
+# Source the Froggy environment file
+source /home/jmetancelin/Code/Parmes/Froggy_Env.sh
+
+# Export the prefix for our custom mpirun
+export MPIPREFIX="/home/perignon/install-gnu-4.8"
+
+# Set a current directory variable
+CURRENT_DIR="/home/$USER/Code/Examples/Froggy_Tools/"
+cd $CURRENT_DIR
+
+# Compute the mpi_rankfile on the allocated nodes.
+# It places 2 processes on each node since each node has 2 GPU. The processes are located on the 1st slot of each socket.
+# The OAR_NODE_FILE is parsed to the mpi_rankfile file
+# example of a mpi_rankfile line : rank 0=keplernodes2 slot=0:0 -> Place the 1st rank on the 1st core of the 1st socket of the node keplernodes2
+nbcorespernode=2
+awk -v i=0 -v n=$nbcorespernode 'x[$0]<n { x[$0]++; print "rank " i "=" $0 " slot=" (i++)%n }' $OAR_NODE_FILE > $CURRENT_DIR'mpi_rankfile_'$OAR_JOB_ID
+# The number of cores is collected for the mpi_rankfile
+nbcores=`cat $CURRENT_DIR'mpi_rankfile' | wc -l`
+
+# The mpirun command.
+# It uses the mpi_rankfile just created above. The prefix of the mpirun command is given.
+# One must forward the 3 environment variables : PATH, PYTHONPATH and LD_LIBRARY_PATH
+mpirun --rankfile $CURRENT_DIR'mpi_rankfile_'$OAR_JOB_ID --prefix $MPIPREFIX -x PYTHONPATH -x PATH -x LD_LIBRARY_PATH -np $nbcores python $CURRENT_DIR'MPI_HelloWorld.py'
diff --git a/Examples/Tools/plot_2D.gp b/Examples/Tools/plot_2D.gp
new file mode 100644
index 0000000000000000000000000000000000000000..b59d58d6ad4d3659404aa72c32a0532df408b5e0
--- /dev/null
+++ b/Examples/Tools/plot_2D.gp
@@ -0,0 +1,8 @@
+## Script Gnuplot d'animation 2D de résultats de new_ParMePy
+f=50
+i=0
+while (i<=f) {
+ sp sprintf("res/RK2_results_%05d.dat",i) u 3:4:7:7 pt 7 ps 0.25 palette t sprintf("%05d",i)
+ i=i+1
+ pause 0.1
+}
\ No newline at end of file
diff --git a/Examples/Tools/plot_3D.gp b/Examples/Tools/plot_3D.gp
new file mode 100644
index 0000000000000000000000000000000000000000..661d20ce1d4959d088219270badf0e3018213358
--- /dev/null
+++ b/Examples/Tools/plot_3D.gp
@@ -0,0 +1,8 @@
+## Script Gnuplot d'animation 3D de résultats de new_ParMePy
+f=50
+i=0
+while (i<=f) {
+ sp sprintf("res/RK2_results_%05d.dat",i) u 4:5:6:10 pt 7 ps 0.25 palette t sprintf("%05d",i)
+ i=i+1
+ pause 0.1
+}
\ No newline at end of file
diff --git a/Examples/Tools/print_volume_2D.gp b/Examples/Tools/print_volume_2D.gp
new file mode 100644
index 0000000000000000000000000000000000000000..a8dd09cefed8f15115e1b010e4161d24ca92e5ca
--- /dev/null
+++ b/Examples/Tools/print_volume_2D.gp
@@ -0,0 +1,19 @@
+reset
+set auto
+
+vol_theo = pi*0.15*0.15
+
+set title "Volume en fonction du temps"
+set xl 'temps'
+set yl 'volume'
+set ytics nomirror
+set y2l 'erreur relative'
+set y2tics
+set key outside bottom center maxrows 1 box height 1
+set yr [0:*]
+
+p'volume.dat' u ($0*0.07):1 w lp t 'volume' axes x1y1,\
+ (vol_theo) t'volume théorique' axes x1y1, \
+ 'volume.dat' u ($0*0.07):(abs($1-vol_theo)/vol_theo) t 'erreur' w lp axes x1y2
+
+l'loop.gp'
\ No newline at end of file
diff --git a/Examples/Tools/print_volume_3D.gp b/Examples/Tools/print_volume_3D.gp
new file mode 100644
index 0000000000000000000000000000000000000000..f7baf84c69d2f69e0a8d9a54b2a1461359b749a5
--- /dev/null
+++ b/Examples/Tools/print_volume_3D.gp
@@ -0,0 +1,19 @@
+reset
+set auto
+
+vol_theo = 4.0*pi*0.15*0.15*0.15/3.0
+
+set title "Volume en fonction du temps"
+set xl 'temps'
+set yl 'volume'
+set ytics nomirror
+set y2l 'erreur relative'
+set y2tics
+set key outside bottom center maxrows 1 box height 1
+set yr [0:*]
+
+p'volume.dat' u ($0*0.07):1 w lp t 'volume' axes x1y1,\
+ (vol_theo) t'volume théorique' axes x1y1, \
+ 'volume.dat' u ($0*0.07):(abs($1-vol_theo)/vol_theo) t 'erreur' w lp axes x1y2
+
+l'loop.gp'
\ No newline at end of file
diff --git a/HySoP/CMake/CMakeListsForTests.cmake b/HySoP/CMake/CMakeListsForTests.cmake
new file mode 100644
index 0000000000000000000000000000000000000000..bdb9e0596407014fc9d71cc8be394c02c5f527f2
--- /dev/null
+++ b/HySoP/CMake/CMakeListsForTests.cmake
@@ -0,0 +1,26 @@
+# -*- cmake -*-
+# This is the test cmake configuration
+# built from @CMAKE_SOURCE_DIR@/cmake/CMakeListsForTests.cmake.in
+
+# scan the list of test executables
+foreach(_EXE ${_EXE_LIST_${_CURRENT_TEST_DIRECTORY}})
+
+ message(STATUS "Adding test suite ${_CURRENT_TEST_DIRECTORY}/${_EXE}")
+
+ # Create an executable for the current test
+ add_executable(${_EXE} ${${_EXE}_FSOURCES})
+
+ # Add a dependency between current test and the main library target
+ add_dependencies(${_EXE} ${PROJECT_LIBRARY_NAME})
+ # link current target test with the same lib as for main project lib
+ target_link_libraries(${_EXE} ${PROJECT_LIBRARY_NAME})
+ target_link_libraries(${_EXE} ${LIBS})
+
+ # add test for ctest
+ add_test(${_EXE} ${_EXE})
+
+ set_tests_properties(${_EXE} PROPERTIES FAIL_REGULAR_EXPRESSION "FAILURE;Exception;failed;ERROR")
+ message("ADD MPI TESTS ...")
+ add_test(NAME mpi_${_EXE} COMMAND mpirun -np 4 ${_EXE})
+
+endforeach(_EXE ${_EXE_LIST_${_CURRENT_TEST_DIRECTORY}})
diff --git a/HySoP/CMake/InstallPackage.cmake b/HySoP/CMake/InstallPackage.cmake
new file mode 100644
index 0000000000000000000000000000000000000000..a594a0b3d22f7b0c1440f065dbfcdc3f6c574012
--- /dev/null
+++ b/HySoP/CMake/InstallPackage.cmake
@@ -0,0 +1,62 @@
+#===========================================================
+# Macro to install parmes package
+#
+# F. Pérignon, LJK-CNRS, april 2011
+#
+#===========================================================
+
+macro(install_package)
+
+ if(ARGV2)
+ set(_HEADERS ${ARGV2})
+ endif()
+
+ # Offer the user the choice of overriding the installation directories
+ set(INSTALL_LIB_DIR lib CACHE PATH "Installation directory for libraries")
+ set(INSTALL_BIN_DIR bin CACHE PATH "Installation directory for executables")
+ set(INSTALL_INCLUDE_DIR include CACHE PATH "Installation directory for header files")
+ set(INSTALL_DATA_DIR share CACHE PATH "Installation directory for data files")
+
+ # Make relative paths absolute (needed later on)
+ foreach(p LIB BIN INCLUDE DATA)
+ set(var INSTALL_${p}_DIR)
+ if(NOT IS_ABSOLUTE "${${var}}")
+ set(${var} "${CMAKE_INSTALL_PREFIX}/${${var}}")
+ endif()
+ endforeach()
+
+ # The library
+ install(TARGETS ${ARGV1}
+ EXPORT ${ARGV0}LibraryDepends
+ ARCHIVE DESTINATION "${INSTALL_LIB_DIR}" # static libs
+ LIBRARY DESTINATION "${INSTALL_LIB_DIR}" COMPONENT shlib # shared libs
+ PUBLIC_HEADER DESTINATION "${INSTALL_INCLUDE_DIR}" COMPONENT dev
+ )
+
+ # The headers and modules
+ if(_HEADERS)
+ install(FILES ${_HEADERS} DESTINATION "${INSTALL_INCLUDE_DIR}")
+ endif()
+ install(DIRECTORY ${CMAKE_BINARY_DIR}/Modules DESTINATION "${INSTALL_INCLUDE_DIR}")
+
+ export(TARGETS ${ARGV1} FILE "${PROJECT_BINARY_DIR}/InstallFiles/${ARGV0}LibraryDepends.cmake")
+
+ # Install the export set for use with the install-tree
+ install(EXPORT ${ARGV0}LibraryDepends DESTINATION
+ "${INSTALL_DATA_DIR}/CMake" COMPONENT dev)
+
+ set(${ARGV0}_INCLUDE_DIRS "${INSTALL_INCLUDE_DIR}")
+ set(${ARGV0}_LIB_DIR "${INSTALL_LIB_DIR}")
+ set(${ARGV0}_CMAKE_DIR "${INSTALL_DATA_DIR}/CMake")
+
+ display(${ARGV0}_CMAKE_DIR)
+ configure_file(${CMAKE_SOURCE_DIR}/${ARGV0}Config.cmake.in
+ "${PROJECT_BINARY_DIR}/InstallFiles/${ARGV0}Config.cmake")
+ configure_file(${CMAKE_SOURCE_DIR}/${ARGV0}ConfigVersion.cmake.in
+ "${PROJECT_BINARY_DIR}/InstallFiles/${ARGV0}ConfigVersion.cmake" @ONLY)
+ install(FILES
+ "${PROJECT_BINARY_DIR}/InstallFiles/${ARGV0}Config.cmake"
+ "${PROJECT_BINARY_DIR}/InstallFiles/${ARGV0}ConfigVersion.cmake"
+ DESTINATION "${${ARGV0}_CMAKE_DIR}" COMPONENT dev)
+
+endmacro()
diff --git a/HySoP/CMake/TestFortranAcceptsFlag.cmake b/HySoP/CMake/TestFortranAcceptsFlag.cmake
new file mode 100644
index 0000000000000000000000000000000000000000..73f3b1a1d4cd2d1612bc7203e8987f0ef59c46d0
--- /dev/null
+++ b/HySoP/CMake/TestFortranAcceptsFlag.cmake
@@ -0,0 +1,38 @@
+# - Test Fortran compiler for a flag
+# Check if the Fortran compiler accepts a flag
+#
+# Macro CHECK_Fortran_ACCEPTS_FLAG(FLAGS VARIABLE) -
+# checks if the function exists
+# FLAGS - the flags to try
+# VARIABLE - variable to store the result
+#
+# F. Pérignon - LJK/CNRS - March 2011
+# From Kitware TestCXXAcceptsFlag.cmake
+#
+
+MACRO(CHECK_Fortran_ACCEPTS_FLAG FLAGS VARIABLE)
+ IF(NOT DEFINED ${VARIABLE})
+ MESSAGE(STATUS "Checking to see if Fortran compiler accepts flag ${FLAGS}")
+ FILE(WRITE ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/Dummy.f
+ "program TESTFortran
+ implicit none
+ print *, 'Hello'
+ end program ")
+ TRY_COMPILE(${VARIABLE}
+ ${CMAKE_BINARY_DIR}
+ ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/Dummy.f
+ CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${FLAGS}
+ OUTPUT_VARIABLE OUTPUT)
+ IF(${VARIABLE})
+ MESSAGE(STATUS "Checking to see if Fortran compiler accepts flag ${FLAGS} - yes")
+ FILE(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log
+ "Determining if the Fortran compiler accepts the flag ${FLAGS} passed with "
+ "the following output:\n${OUTPUT}\n\n")
+ ELSE(${VARIABLE})
+ MESSAGE(STATUS "Checking to see if Fortran compiler accepts flag ${FLAGS} - no")
+ FILE(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log
+ "Determining if the Fortran compiler accepts the flag ${FLAGS} failed with "
+ "the following output:\n${OUTPUT}\n\n")
+ ENDIF(${VARIABLE})
+ ENDIF(NOT DEFINED ${VARIABLE})
+ENDMACRO(CHECK_Fortran_ACCEPTS_FLAG)
diff --git a/HySoP/FroggyHowTo.org b/HySoP/FroggyHowTo.org
new file mode 100644
index 0000000000000000000000000000000000000000..c4941c1544345ba48045aab12c8be6ca7a25af6b
--- /dev/null
+++ b/HySoP/FroggyHowTo.org
@@ -0,0 +1,14 @@
+* To use parmespy on Froggy ...
+source /applis/site/env.bash
+module load gcc/4.8.1_gcc-4.4.6
+module load cmake/2.8.11.2_gcc-4.4.6
+. /home/perignon/MyPython/bin/activate
+export PATH=/home/perignon/install-gnu-4.8/bin/:${PATH}
+export LD_LIBRARY_PATH=/home/perignon/install-gnu-4.8/lib/:/applis/site/stow/gcc_4.4.6/gcc_4.8.1/lib64:${LD_LIBRARY_PATH}
+export PYTHONPATH=/home/perignon/MyPython/lib/python2.7/site-packages:/home/perignon/install-gnu-4.8/lib/python2.7/site-packages
+export CC=mpicc CXX=mpic++ FC=mpif90
+unset LDFLAGS
+unset CFLAGS
+cmake path-to-Parmes -Dfftw_DIR=/home/perignon/install-gnu-4.8/
+make install -j 8
+export PYTHONPATH=/home/YOURLOGIN/.local/lib/python2.7/site-packages
diff --git a/HySoP/Froggy_BuildEnv.sh b/HySoP/Froggy_BuildEnv.sh
new file mode 100644
index 0000000000000000000000000000000000000000..5b98a27bfdeaaf0a59cd3a5270a719eea1e500d8
--- /dev/null
+++ b/HySoP/Froggy_BuildEnv.sh
@@ -0,0 +1,16 @@
+## Source this file to get a clean working environment on Froggy
+## It uses the binaries and libraries from /home/perignon
+source /applis/site/env.bash
+module load gcc/4.8.1_gcc-4.4.6
+module load cmake/2.8.11.2_gcc-4.4.6
+. /home/perignon/MyPython/bin/activate
+export PATH=/home/perignon/install-gnu-4.8/bin/:${PATH}
+export LD_LIBRARY_PATH=/home/perignon/install-gnu-4.8/lib/:/applis/site/stow/gcc_4.4.6/gcc_4.8.1/lib64:${LD_LIBRARY_PATH}
+export PYTHONPATH=~/.local/lib/python2.7/site-packages:/home/perignon/MyPython/lib/python2.7/site-packages:/home/perignon/install-gnu-4.8/lib/python2.7/site-packages
+export CC=mpicc CXX=mpic++ FC=mpif90
+unset LDFLAGS
+unset CFLAGS
+
+## Build parmes helping cmake to find FFTW headers:
+# cmake path-to-Parmes -Dfftw_DIR=/home/perignon/install-gnu-4.8/
+# make install -j 8
diff --git a/HySoP/Froggy_Env.sh b/HySoP/Froggy_Env.sh
new file mode 100644
index 0000000000000000000000000000000000000000..dc374f6c54515ccddc115bd72e2c9bf945522e1e
--- /dev/null
+++ b/HySoP/Froggy_Env.sh
@@ -0,0 +1,8 @@
+## Source this file to get a clean working environment on Froggy for running parmes
+## It uses the binaries and libraries from /home/perignon
+source /applis/site/env.bash
+module load gcc/4.8.1_gcc-4.4.6
+. /home/perignon/MyPython/bin/activate
+export PATH=/home/perignon/install-gnu-4.8/bin/:${PATH}
+export LD_LIBRARY_PATH=/home/perignon/install-gnu-4.8/lib/:/applis/site/stow/gcc_4.4.6/gcc_4.8.1/lib64:${LD_LIBRARY_PATH}
+export PYTHONPATH=~/.local/lib/python2.7/site-packages:/home/perignon/MyPython/lib/python2.7/site-packages:/home/perignon/install-gnu-4.8/lib/python2.7/site-packages
diff --git a/HySoP/Global_tests/README b/HySoP/Global_tests/README
new file mode 100644
index 0000000000000000000000000000000000000000..20dd663dfeeb6626ab855bf064b2685d87ff9d0a
--- /dev/null
+++ b/HySoP/Global_tests/README
@@ -0,0 +1,3 @@
+This directory contains py files used to test global functionnalities (a specific operator, a method ...)
+and to check performances and memory usage.
+
diff --git a/HySoP/Global_tests/testPerfAndMemForFD_and_div.py b/HySoP/Global_tests/testPerfAndMemForFD_and_div.py
new file mode 100644
index 0000000000000000000000000000000000000000..f104f55121ebb061b205dbe2b03fb69d0cd8427f
--- /dev/null
+++ b/HySoP/Global_tests/testPerfAndMemForFD_and_div.py
@@ -0,0 +1,305 @@
+#!/usr/bin/python
+
+"""
+Test memory and performances for finite differences operations.
+
+"""
+
+import parmepy as pp
+import parmepy.tools.numpywrappers as npw
+import math as m
+from parmepy.fields.continuous import Field
+from parmepy.mpi.topology import Cartesian
+from parmepy.operator.stretching import Stretching
+
+
+## ----------- A 3d problem -----------
+print " ========= Start Finite Differences tests ========="
+dim = 3
+pi = m.pi
+sin = m.sin
+cos = m.cos
+## Domain
+box = pp.Box(dim, length=[2.0 * pi, 2.0 * pi, 2.0 * pi])
+
+## Global resolution
+nb = 65
+nbElem = [nb] * dim
+
+
+## Function to compute velocity
+def computeVel(x, y, z):
+ vx = sin(x) * cos(y) * cos(z)
+ vy = - cos(x) * sin(y) * cos(z)
+ vz = 0.
+ return vx, vy, vz
+
+
+## Function to compute vorticity
+def computeVort(x, y, z):
+ wx = - cos(x) * sin(y) * sin(z)
+ wy = - sin(x) * cos(y) * sin(z)
+ wz = 2. * sin(x) * sin(y) * cos(z)
+ return wx, wy, wz
+
+## Fields
+velo = Field(domain=box, formula=computeVel,
+ name='Velocity', isVector=True)
+vorti = Field(domain=box, formula=computeVort,
+ name='VorticityC', isVector=True)
+
+## A topology with ghosts
+NBGHOSTS = 2
+ghosts = npw.ones((box.dimension)) * NBGHOSTS
+topo = Cartesian(box, box.dimension, nbElem,
+ ghosts=ghosts)
+
+## local coordinates
+coords = topo.mesh.coords
+## Fields discretization
+velo.discretize(topo)
+vorti.discretize(topo)
+velo.initialize()
+vorti.initialize()
+
+## alias to discrete fields components
+w = vorti.discreteFields.values()[0].data
+v = velo.discreteFields.values()[0].data
+
+from parmepy.mpi import MPI
+from parmepy.numerics.finite_differences import FD_C_4
+
+## FD scheme creation and init
+fd_scheme = FD_C_4((topo.mesh.space_step))
+fd_scheme.computeIndices(topo.mesh.iCompute)
+
+import numpy as np
+#### Timings for finite differences schemes
+
+iter = 10
+# Allocation of work vector to store results
+result = npw.zeros_like(w[0])
+
+## Add raw_input to check memory with htop
+print 'press any key to start tests'
+raw_input()
+
+########### Test 1 : finite diff. direct call ###########
+
+#### First method #####
+print 'start ...'
+time = MPI.Wtime()
+for i in xrange(iter):
+ fd_scheme.compute(w[0], 0, result)
+print 'FD compute method time ', MPI.Wtime() - time
+raw_input()
+print 'start ... '
+#### Second method #####
+time = MPI.Wtime()
+for i in xrange(iter):
+ fd_scheme.compute_and_add(w[0], 0, result)
+print 'FD compute_and_add method time ', MPI.Wtime() - time
+
+del result
+iter = 1
+
+#
+# Res : first method is faster and cost less in memory
+#
+
+########### Test 2 : 'FD, with accumulation of the result ###########
+
+result = [npw.zeros_like(w[0]) for i in xrange(2)]
+
+## fd results are accumulated into result[0]
+
+raw_input()
+print 'start'
+#### First method ####
+## Needs at least two workspaces and one is used for the final result.
+time = MPI.Wtime()
+for i in xrange(iter):
+ #for cdir in xrange(3):
+ fd_scheme.compute(w[0], 0, result[0])
+ fd_scheme.compute(w[1], 0, result[1])
+ np.add(result[0], result[1], result[0])
+ fd_scheme.compute(w[2], 0, result[1])
+ np.add(result[0], result[1], result[0])
+print 'Accumulate/FD Compute meth time ', MPI.Wtime() - time
+
+raw_input()
+print 'start ...'
+result2 = npw.zeros_like(w[0])
+#### Second method ####
+## Needs only one workspace, used for the final result.
+time = MPI.Wtime()
+for i in xrange(iter):
+ #for cdir in xrange(3):
+ fd_scheme.compute(w[0], 0, result2)
+ fd_scheme.compute_and_add(w[1], 0, result2)
+ fd_scheme.compute_and_add(w[2], 0, result2)
+print 'Accumulate/FD Compute_and_add meth time ', MPI.Wtime() - time
+
+print 'Computation ok? ', np.allclose(result[0], result2)
+del result
+del result2
+
+#
+# Res : first method is faster and cost less in memory
+#
+
+########### Test 3 : 'real' case
+# corresponding more or less to divV computation ###########
+# Needs an intermediate workspace to compute w.v
+raw_input()
+print 'start ...'
+work = [npw.zeros_like(w[0]) for i in xrange(3)]
+raw_input()
+
+## fd results are accumulated into result[0]
+
+#### First method ####
+## Needs at least three workspaces and one is used for the final result.
+time = MPI.Wtime()
+for i in xrange(iter):
+ #for cdir in xrange(3):
+ work[2][...] = v[0] * w[0]
+ fd_scheme.compute(work[2], 0, work[0])
+ work[2][...] = v[0] * w[1]
+ fd_scheme.compute(work[2], 0, work[1])
+ np.add(work[0], work[1], work[0])
+ work[2][...] = v[0] * w[2]
+ fd_scheme.compute(work[2], 0, work[1])
+ np.add(work[0], work[1], work[0])
+print 'Div/FD Compute meth time ', MPI.Wtime() - time
+time = MPI.Wtime()
+for i in xrange(iter):
+ #for cdir in xrange(3):
+ work[2][...] = v[0] * w[0]
+ fd_scheme.compute(work[2], 0, work[0])
+ work[2][...] = v[0] * w[1]
+ fd_scheme.compute(work[2], 0, work[1])
+ work[0][...] += work[1]
+ work[2][...] = v[0] * w[2]
+ fd_scheme.compute(work[2], 0, work[1])
+ work[0][...] += work[1]
+print 'Div/FD Compute meth time (bis) ', MPI.Wtime() - time
+
+#### Second method ####
+## Needs only two workspace, used for the final result.
+raw_input()
+print 'start ...'
+work2 = [npw.zeros_like(w[0]) for i in xrange(2)]
+raw_input()
+
+print 'pre id ...', id(work2[1])
+time = MPI.Wtime()
+for i in xrange(iter):
+ #for cdir in xrange(3):
+ work2[1][...] = v[0] * w[0]
+ print 'post id ...', id(work2[1])
+ fd_scheme.compute(work2[1], 0, work2[0])
+ work2[1][...] = v[0] * w[1]
+ fd_scheme.compute_and_add(work2[1], 0, work2[0])
+ work2[1][...] = v[0] * w[2]
+ fd_scheme.compute_and_add(work2[1], 0, work2[0])
+print 'Div/FD Compute_and_add meth time ', MPI.Wtime() - time
+
+print 'Computation ok? ', np.allclose(work[0], work2[0])
+
+del work
+del work2
+#
+# Res : first method is faster and cost less in memory
+# (but it's almost the same)
+#
+
+########### Test 4 : 'real' case
+# corresponding more or less to divT computation ###########
+# Needs an intermediate workspace to compute w.v
+
+raw_input()
+print 'start ...'
+work = [npw.zeros_like(w[0]) for i in xrange(5)]
+raw_input()
+
+## fd results are accumulated into work[0:2]
+
+#### First method ####
+## Needs at least five workspaces and three are used for the final result.
+# work[i] = divV(w vi)
+time = MPI.Wtime()
+for i in xrange(iter):
+ # Compute first component of divT ...
+ work[2] = v[0] * w[0]
+ fd_scheme.compute(work[2], 0, work[0])
+ work[2] = v[0] * w[1]
+ fd_scheme.compute(work[2], 0, work[1])
+ np.add(work[0], work[1], work[0])
+ work[2] = v[0] * w[2]
+ fd_scheme.compute(work[2], 0, work[1])
+ np.add(work[0], work[1], work[0])
+ # Second component ... work[0] can not be used anymore
+ work[3] = v[0] * w[0]
+ fd_scheme.compute(work[3], 0, work[1])
+ work[3] = v[0] * w[1]
+ fd_scheme.compute(work[3], 0, work[2])
+ np.add(work[1], work[2], work[1])
+ work[3] = v[0] * w[2]
+ fd_scheme.compute(work[3], 0, work[2])
+ np.add(work[1], work[2], work[1])
+ # Last component ... work[0] and work[1] can not be used anymore
+ work[4] = v[0] * w[0]
+ fd_scheme.compute(work[4], 0, work[2])
+ work[4] = v[0] * w[1]
+ fd_scheme.compute(work[4], 0, work[3])
+ np.add(work[2], work[3], work[2])
+ work[4] = v[0] * w[2]
+ fd_scheme.compute(work[4], 0, work[3])
+ np.add(work[2], work[3], work[2])
+
+print 'DivT/FD Compute meth time ', MPI.Wtime() - time
+#### Second method ####
+## Needs only 4 workspaces, used for the final result.
+raw_input()
+print 'start ...'
+work2 = [npw.zeros_like(w[0]) for i in xrange(4)]
+time = MPI.Wtime()
+for i in xrange(iter):
+ # Compute first component of divT ...
+ work2[3] = v[0] * w[0]
+ fd_scheme.compute(work2[3], 0, work2[0])
+ work2[3] = v[0] * w[1]
+ fd_scheme.compute_and_add(work2[3], 0, work2[0])
+ work2[3] = v[0] * w[2]
+ fd_scheme.compute_and_add(work2[3], 0, work2[0])
+ # Second component ... work2[0] can not be used anymore
+ work2[3] = v[0] * w[0]
+ fd_scheme.compute(work2[3], 0, work2[1])
+ work2[3] = v[0] * w[1]
+ fd_scheme.compute_and_add(work2[3], 0, work2[1])
+ work2[3] = v[0] * w[2]
+ fd_scheme.compute_and_add(work2[3], 0, work2[1])
+ # Last component ... work2[0] and work2[1] can not be used anymore
+ work2[3] = v[0] * w[0]
+ fd_scheme.compute(work2[3], 0, work2[2])
+ work2[3] = v[0] * w[1]
+ fd_scheme.compute_and_add(work2[3], 0, work2[2])
+ work2[3] = v[0] * w[2]
+ fd_scheme.compute_and_add(work2[3], 0, work2[2])
+
+print 'DivT/FD Compute_and_add meth time ', MPI.Wtime() - time
+
+ind = topo.mesh.iCompute
+for i in xrange(3):
+ print 'Computation ok? ', np.allclose(work[i][ind], work2[i][ind])
+#
+# Res : first method is faster and cost less in memory
+# (but it's almost the same)
+#
+
+
+## Conclusion (if res > 200 **)-> it seems that first method, although it needs
+# more initial workspaces, is always faster and cheaper
+# concerning memory (because of hidden tmp alloc)
+# BUT for smaller resolutions, second method may be more efficient ...
diff --git a/HySoP/HySoPConfig.cmake.in b/HySoP/ParmesConfig.cmake.in
similarity index 100%
rename from HySoP/HySoPConfig.cmake.in
rename to HySoP/ParmesConfig.cmake.in
diff --git a/HySoP/HySoPConfigVersion.cmake.in b/HySoP/ParmesConfigVersion.cmake.in
similarity index 100%
rename from HySoP/HySoPConfigVersion.cmake.in
rename to HySoP/ParmesConfigVersion.cmake.in
diff --git a/HySoP/ParmesToSinglePrecision.patch b/HySoP/ParmesToSinglePrecision.patch
new file mode 100644
index 0000000000000000000000000000000000000000..5e644fe4edc133ed4547d745e4b9ffe4a67aa5ce
--- /dev/null
+++ b/HySoP/ParmesToSinglePrecision.patch
@@ -0,0 +1,947 @@
+diff --git parmepy/constants.py parmepy/constants.py
+index 3672059..3022c21 100644
+--- parmepy/constants.py
++++ parmepy/constants.py
+@@ -18,13 +18,13 @@ else:
+
+ PI = math.pi
+ # Set default type for real and integer numbers
+-PARMES_REAL = np.float64
++PARMES_REAL = np.float32
+ # type for array indices
+ PARMES_INDEX = np.uint32
+ # type for integers
+-PARMES_INTEGER = np.int64
++PARMES_INTEGER = np.int32
+ # float type for MPI messages
+-PARMES_MPI_REAL = MPI.DOUBLE
++PARMES_MPI_REAL = MPI.REAL
+ ## default array layout (fortran or C convention)
+ ORDER = 'F'
+ # to check array ordering with :
+diff --git parmepy/f2py/fftw2py.f90 parmepy/f2py/fftw2py.f90
+index 8645a9f..718eb19 100755
+--- parmepy/f2py/fftw2py.f90
++++ parmepy/f2py/fftw2py.f90
+@@ -5,7 +5,7 @@
+ module fftw2py
+
+ use client_data
+- use parmesparam
++ use parmesparam_sp
+ !> 2d case
+ use fft2d
+ !> 3d case
+@@ -81,7 +81,7 @@ contains
+ subroutine solve_poisson_2d(omega,velocity_x,velocity_y)
+ real(pk),dimension(:,:),intent(in):: omega
+ real(pk),dimension(size(omega,1),size(omega,2)),intent(out) :: velocity_x,velocity_y
+- real(pk) :: start
++ real(8) :: start
+ !f2py intent(in,out) :: velocity_x,velocity_y
+ start = MPI_WTime()
+
+@@ -117,7 +117,7 @@ contains
+ real(pk),dimension(:,:,:),intent(in):: omega_x,omega_y,omega_z
+ real(pk),dimension(size(omega_x,1),size(omega_y,2),size(omega_z,3)),intent(out) :: velocity_x,velocity_y,velocity_z
+ integer, dimension(3), intent(in) :: ghosts_vort, ghosts_velo
+- real(pk) :: start
++ real(8) :: start
+ !f2py intent(in,out) :: velocity_x,velocity_y,velocity_z
+ start = MPI_WTime()
+ call r2c_3d(omega_x,omega_y,omega_z, ghosts_vort)
+diff --git parmepy/f2py/scales2py.f90 parmepy/f2py/scales2py.f90
+index ab5b440..d56112e 100755
+--- parmepy/f2py/scales2py.f90
++++ parmepy/f2py/scales2py.f90
+@@ -6,7 +6,7 @@ use advec, only : advec_init,advec_step,advec_step_Inter_basic,advec_step_Inter_
+ use advec_vect, only : advec_step_Vect,advec_step_Inter_basic_Vect
+ use interpolation_velo, only : interpol_init
+ use mpi
+-use parmesparam
++use parmesparam_sp
+
+
+ implicit none
+@@ -93,7 +93,7 @@ contains
+ real(pk), dimension(size(vx,1),size(vx,2),size(vx,3)), intent(inout) :: scal
+ !f2py real(pk) intent(in,out), depend(size(vx,1)) :: scal
+
+- real(pk) :: t0
++ real(8) :: t0
+
+ t0 = MPI_Wtime()
+ call advec_step(dt,vx,vy,vz,scal)
+diff --git setup.py.in setup.py.in
+index f771350..22fd086 100644
+--- setup.py.in
++++ setup.py.in
+@@ -71,8 +71,8 @@ if(enable_fortran is "ON"):
+ fortran_src.append(fortran_dir+'fftw2py.f90')
+ fftwdir = '@FFTWLIB@'
+ fftwdir = os.path.split(fftwdir)[0]
+- parmeslib.append('fftw3')
+- parmeslib.append('fftw3_mpi')
++ parmeslib.append('fftw3f')
++ parmeslib.append('fftw3f_mpi')
+ parmes_libdir.append(fftwdir)
+ else:
+ packages.append('parmepy.fakef2py')
+diff --git src/client_data.f90 src/client_data.f90
+index 46b5268..77178d9 100755
+--- src/client_data.f90
++++ src/client_data.f90
+@@ -1,14 +1,14 @@
+ !> Some global parameters and variables
+ module client_data
+
+- use MPI, only : MPI_DOUBLE_PRECISION
++ use MPI, only : MPI_REAL
+ use, intrinsic :: iso_c_binding ! required for fftw
+ implicit none
+
+ !> kind for real variables (simple or double precision)
+- integer, parameter :: mk = kind(1.0d0) ! double precision
++ integer, parameter :: mk = kind(1.0) ! single precision
+ !> kind for real variables in mpi routines
+- integer, parameter :: mpi_mk = MPI_DOUBLE_PRECISION
++ integer, parameter :: mpi_mk = MPI_REAL
+ !> Problem dimension (model, required for ppm to work properly)
+ integer, parameter :: dime = 2
+ !> Real dimension
+@@ -26,7 +26,7 @@ module client_data
+ !> to activate (or not) screen output
+ logical,parameter :: verbose = .True.
+ !> i (sqrt(-1) ...)
+- complex(C_DOUBLE_COMPLEX), parameter :: Icmplx = cmplx(0._mk,1._mk, kind=mk)
++ complex(C_FLOAT_COMPLEX), parameter :: Icmplx = cmplx(0._mk,1._mk, kind=mk)
+ !> tolerance used to compute error
+ real(mk), parameter :: tolerance = 1e-12
+
+diff --git src/fftw/Poisson.f90 src/fftw/Poisson.f90
+index 78b355c..8804e3d 100755
+--- src/fftw/Poisson.f90
++++ src/fftw/Poisson.f90
+@@ -53,7 +53,7 @@ contains
+ real(mk),dimension(:,:,:),intent(in) :: omega_x,omega_y,omega_z
+ real(mk),dimension(:,:,:),intent(inout) :: velocity_x,velocity_y,velocity_z
+ integer, dimension(3), intent(in) :: ghosts_w, ghosts_v
+- real(mk) :: start
++ real(8) :: start
+ !! Compute fftw forward transform
+ !! Omega is used to initialize the fftw buffer for input field.
+
+@@ -74,7 +74,7 @@ contains
+
+ real(mk),dimension(:,:,:),intent(in) :: omega_x,omega_y,omega_z
+ real(mk),dimension(:,:,:),intent(inout) :: velocity_x,velocity_y,velocity_z
+- real(mk) :: start
++ real(8) :: start
+ !! Compute fftw forward transform
+ !! Omega is used to initialize the fftw buffer for input field.
+
+diff --git src/fftw/fft2d.f90 src/fftw/fft2d.f90
+index c56412f..7edbfd3 100755
+--- src/fftw/fft2d.f90
++++ src/fftw/fft2d.f90
+@@ -36,15 +36,15 @@ module fft2d
+ type(C_PTR) :: cbuffer2
+ !! Note Franck : check if local declarations of datain/out works and improve perfs.
+ !> Field (complex values) for fftw input
+- complex(C_DOUBLE_COMPLEX), pointer :: datain1(:,:),datain2(:,:)
++ complex(C_FLOAT_COMPLEX), pointer :: datain1(:,:),datain2(:,:)
+ !> Field (real values) for fftw input
+- real(C_DOUBLE), pointer :: rdatain1(:,:)
++ real(C_FLOAT), pointer :: rdatain1(:,:)
+ !> Field (complex values) for fftw (forward) output
+- complex(C_DOUBLE_COMPLEX), pointer :: dataout1(:,:)
++ complex(C_FLOAT_COMPLEX), pointer :: dataout1(:,:)
+ !> Field (real values) for fftw output
+- real(C_DOUBLE), pointer :: rdatain2(:,:)
++ real(C_FLOAT), pointer :: rdatain2(:,:)
+ !> Field (complex values) for fftw (forward) output
+- complex(C_DOUBLE_COMPLEX), pointer :: dataout2(:,:)
++ complex(C_FLOAT_COMPLEX), pointer :: dataout2(:,:)
+ !> GLOBAL number of points in each direction
+ integer(C_INTPTR_T),pointer :: fft_resolution(:)
+ !> LOCAL resolution
+@@ -52,13 +52,13 @@ module fft2d
+ !> Offset in the direction of distribution
+ integer(c_INTPTR_T),dimension(2) :: local_offset
+ !> wave numbers for fft in x direction
+- real(C_DOUBLE), pointer :: kx(:)
++ real(C_FLOAT), pointer :: kx(:)
+ !> wave numbers for fft in y direction
+- real(C_DOUBLE), pointer :: ky(:)
++ real(C_FLOAT), pointer :: ky(:)
+ !> log file for fftw
+ character(len=20),parameter :: filename ="parmesfftw.log"
+ !> normalization factor
+- real(C_DOUBLE) :: normFFT
++ real(C_FLOAT) :: normFFT
+ !> true if all the allocation stuff for global variables has been done.
+ logical :: is2DUpToDate = .false.
+
+@@ -81,7 +81,7 @@ contains
+ if(is2DUpToDate) return
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+
+@@ -90,27 +90,27 @@ contains
+ fft_resolution = resolution-1
+
+ ! compute "optimal" size (according to fftw) for local date (warning : dimension reversal)
+- alloc_local = fftw_mpi_local_size_2d_transposed(fft_resolution(c_Y),fft_resolution(c_X),main_comm,&
++ alloc_local = fftwf_mpi_local_size_2d_transposed(fft_resolution(c_Y),fft_resolution(c_X),main_comm,&
+ local_resolution(c_Y),local_offset(c_Y),local_resolution(c_X),local_offset(c_X));
+
+ ! allocate local buffer (used to save datain/dataout1 ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
+ ! link datain and dataout1 to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, datain1, [fft_resolution(c_X),local_resolution(c_Y)])
+ call c_f_pointer(cbuffer1, dataout1, [fft_resolution(c_Y),local_resolution(c_X)])
+
+ ! second buffer used for backward transform. Used to copy dataout1 into dataout2 (input for backward transform and filter)
+ ! and to save (in-place) the transform of the second component of the velocity
+- cbuffer2 = fftw_alloc_complex(alloc_local)
++ cbuffer2 = fftwf_alloc_complex(alloc_local)
+ call c_f_pointer(cbuffer2, datain2, [fft_resolution(c_X),local_resolution(c_Y)])
+ call c_f_pointer(cbuffer2, dataout2, [fft_resolution(c_Y),local_resolution(c_X)])
+
+ ! create MPI plan for in-place forward/backward DFT (note dimension reversal)
+- plan_forward1 = fftw_mpi_plan_dft_2d(fft_resolution(c_Y), fft_resolution(c_X),datain1,dataout1,&
++ plan_forward1 = fftwf_mpi_plan_dft_2d(fft_resolution(c_Y), fft_resolution(c_X),datain1,dataout1,&
+ main_comm,FFTW_FORWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_dft_2d(fft_resolution(c_Y),fft_resolution(c_X),dataout1,datain1,&
++ plan_backward1 = fftwf_mpi_plan_dft_2d(fft_resolution(c_Y),fft_resolution(c_X),dataout1,datain1,&
+ main_comm,FFTW_BACKWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_backward2 = fftw_mpi_plan_dft_2d(fft_resolution(c_Y),fft_resolution(c_X),dataout2,datain2,&
++ plan_backward2 = fftwf_mpi_plan_dft_2d(fft_resolution(c_Y),fft_resolution(c_X),dataout2,datain2,&
+ main_comm,FFTW_BACKWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+
+ call computeKxC(lengths(c_X))
+@@ -139,7 +139,7 @@ contains
+ end do
+
+ ! compute transform (as many times as desired)
+- call fftw_mpi_execute_dft(plan_forward1, datain1, dataout1)
++ call fftwf_mpi_execute_dft(plan_forward1, datain1, dataout1)
+
+ !!$ do i = 1, fft_resolution(c_Y)
+ !!$ write(*,'(a,i5,a,16f10.4)') 'out[',rank,'] ', dataout1(i,1:local_resolution(c_X))
+@@ -147,8 +147,8 @@ contains
+ !!$
+ call filter_poisson_2d()
+
+- call fftw_mpi_execute_dft(plan_backward1, dataout1, datain1)
+- call fftw_mpi_execute_dft(plan_backward2,dataout2,datain2)
++ call fftwf_mpi_execute_dft(plan_backward1, dataout1, datain1)
++ call fftwf_mpi_execute_dft(plan_backward2,dataout2,datain2)
+ do j = 1, local_resolution(c_Y)
+ do i = 1, fft_resolution(c_X)
+ velocity_x(i,j) = datain1(i,j)*normFFT
+@@ -183,7 +183,7 @@ contains
+ if(is2DUpToDate) return
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+
+@@ -191,11 +191,11 @@ contains
+ fft_resolution(:) = resolution(:)-1
+ halfLength = fft_resolution(c_X)/2+1
+ ! allocate local buffer (used to save datain/dataout1 ==> in-place transform!!)
+- alloc_local = fftw_mpi_local_size_2d_transposed(fft_resolution(c_Y),halfLength,main_comm,local_resolution(c_Y),&
++ alloc_local = fftwf_mpi_local_size_2d_transposed(fft_resolution(c_Y),halfLength,main_comm,local_resolution(c_Y),&
+ local_offset(c_Y),local_resolution(c_X),local_offset(c_X));
+
+ ! allocate local buffer (used to save datain/dataout1 ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
+
+ ! link rdatain1 and dataout1 to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, rdatain1, [2*halfLength,local_resolution(c_Y)])
+@@ -203,17 +203,17 @@ contains
+
+ ! second buffer used for backward transform. Used to copy dataout1 into dataout2 (input for backward transform and filter)
+ ! and to save (in-place) the transform of the second component of the velocity
+- cbuffer2 = fftw_alloc_complex(alloc_local)
++ cbuffer2 = fftwf_alloc_complex(alloc_local)
+
+ call c_f_pointer(cbuffer2, rdatain2, [2*halfLength,local_resolution(c_Y)])
+ call c_f_pointer(cbuffer2, dataout2, [fft_resolution(c_Y),local_resolution(c_X)])
+
+ ! create MPI plans for in-place forward/backward DFT (note dimension reversal)
+- plan_forward1 = fftw_mpi_plan_dft_r2c_2d(fft_resolution(c_Y), fft_resolution(c_X), rdatain1, dataout1, &
++ plan_forward1 = fftwf_mpi_plan_dft_r2c_2d(fft_resolution(c_Y), fft_resolution(c_X), rdatain1, dataout1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
++ plan_backward1 = fftwf_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_backward2 = fftw_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
++ plan_backward2 = fftwf_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+
+ call computeKx(lengths(c_X))
+@@ -248,7 +248,7 @@ contains
+ !!$ end do
+ !!$
+ ! compute transform (as many times as desired)
+- call fftw_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
++ call fftwf_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
+
+ !!$ do i = 1, fft_resolution(c_Y)
+ !!$ write(*,'(a,i5,a,16f10.4)') 'aaaa[',rank,'] ', dataout1(i,1:local_resolution(c_X))
+@@ -261,8 +261,8 @@ contains
+ real(mk),dimension(:,:),intent(inout) :: velocity_x,velocity_y
+ integer(C_INTPTR_T) :: i, j
+
+- call fftw_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
+- call fftw_mpi_execute_dft_c2r(plan_backward2,dataout2,rdatain2)
++ call fftwf_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
++ call fftwf_mpi_execute_dft_c2r(plan_backward2,dataout2,rdatain2)
+ do j = 1, local_resolution(c_Y)
+ do i = 1, fft_resolution(c_X)
+ velocity_x(i,j) = rdatain1(i,j)*normFFT
+@@ -288,7 +288,7 @@ contains
+ real(mk),dimension(:,:),intent(inout) :: omega
+ integer(C_INTPTR_T) :: i, j
+
+- call fftw_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
++ call fftwf_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
+ do j = 1, local_resolution(c_Y)
+ do i = 1, fft_resolution(c_X)
+ omega(i,j) = rdatain1(i,j)*normFFT
+@@ -390,7 +390,7 @@ contains
+ subroutine filter_poisson_2d()
+
+ integer(C_INTPTR_T) :: i, j
+- complex(C_DOUBLE_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: coeff
+ if(local_offset(c_X)==0) then
+ if(local_offset(c_Y) == 0) then
+ dataout1(1,1) = 0.0
+@@ -437,9 +437,9 @@ contains
+
+ subroutine filter_diffusion_2d(nudt)
+
+- real(C_DOUBLE), intent(in) :: nudt
++ real(C_FLOAT), intent(in) :: nudt
+ integer(C_INTPTR_T) :: i, j
+- complex(C_DOUBLE_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: coeff
+
+ do i = 1,local_resolution(c_X)
+ do j = 1, fft_resolution(c_Y)
+@@ -452,20 +452,20 @@ contains
+
+ !> Clean fftw context (free memory, plans ...)
+ subroutine cleanFFTW_2d()
+- call fftw_destroy_plan(plan_forward1)
+- call fftw_destroy_plan(plan_backward1)
+- !call fftw_destroy_plan(plan_forward2)
+- !call fftw_destroy_plan(plan_backward2)
+- call fftw_free(cbuffer1)
+- call fftw_free(cbuffer2)
+- call fftw_mpi_cleanup()
++ call fftwf_destroy_plan(plan_forward1)
++ call fftwf_destroy_plan(plan_backward1)
++ !call fftwf_destroy_plan(plan_forward2)
++ !call fftwf_destroy_plan(plan_backward2)
++ call fftwf_free(cbuffer1)
++ call fftwf_free(cbuffer2)
++ call fftwf_mpi_cleanup()
+ deallocate(fft_resolution)
+ if(rank==0) close(21)
+ end subroutine cleanFFTW_2d
+
+ subroutine fft2d_diagnostics(nbelem)
+ integer(C_INTPTR_T), intent(in) :: nbelem
+- complex(C_DOUBLE_COMPLEX) :: memoryAllocated
++ complex(C_FLOAT_COMPLEX) :: memoryAllocated
+ memoryAllocated = real(nbelem*sizeof(memoryAllocated),mk)*1e-6
+ write(*,'(a,i5,a,i12,f10.2)') '[',rank,'] size of each buffer (elements / memory in MB):', &
+ nbelem, memoryAllocated
+@@ -499,10 +499,10 @@ contains
+ integer(C_INTPTR_T), dimension(2) :: n
+
+ !> Field (real values) for fftw input
+- real(C_DOUBLE), pointer :: rdatain1Many(:,:,:)
++ real(C_FLOAT), pointer :: rdatain1Many(:,:,:)
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+ howmany = 1
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+
+@@ -514,12 +514,12 @@ contains
+ n(1) = fft_resolution(2)
+ n(2) = halfLength
+ ! allocate local buffer (used to save datain/dataout1 ==> in-place transform!!)
+- alloc_local = fftw_mpi_local_size_many_transposed(2,n,howmany,FFTW_MPI_DEFAULT_BLOCK,&
++ alloc_local = fftwf_mpi_local_size_many_transposed(2,n,howmany,FFTW_MPI_DEFAULT_BLOCK,&
+ FFTW_MPI_DEFAULT_BLOCK,main_comm,local_resolution(c_Y),&
+ local_offset(c_Y),local_resolution(c_X),local_offset(c_X));
+
+ ! allocate local buffer (used to save datain/dataout1 ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
+
+ ! link rdatain1 and dataout1 to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, rdatain1Many, [howmany,2*halfLength,local_resolution(c_Y)])
+@@ -527,17 +527,17 @@ contains
+
+ ! second buffer used for backward transform. Used to copy dataout1 into dataout2 (input for backward transform and filter)
+ ! and to save (in-place) the transform of the second component of the velocity
+- cbuffer2 = fftw_alloc_complex(alloc_local)
++ cbuffer2 = fftwf_alloc_complex(alloc_local)
+
+ call c_f_pointer(cbuffer2, rdatain1Many, [howmany,2*halfLength,local_resolution(c_Y)])
+ call c_f_pointer(cbuffer2, dataout2, [fft_resolution(c_Y),local_resolution(c_X)])
+
+ ! create MPI plans for in-place forward/backward DFT (note dimension reversal)
+- plan_forward1 = fftw_mpi_plan_dft_r2c_2d(fft_resolution(c_Y), fft_resolution(c_X), rdatain1Many, dataout1, &
++ plan_forward1 = fftwf_mpi_plan_dft_r2c_2d(fft_resolution(c_Y), fft_resolution(c_X), rdatain1Many, dataout1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
++ plan_backward1 = fftwf_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_backward2 = fftw_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
++ plan_backward2 = fftwf_mpi_plan_dft_c2r_2d(fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+
+ call computeKx(lengths(c_X))
+diff --git src/fftw/fft3d.f90 src/fftw/fft3d.f90
+index 1b06457..a857855 100755
+--- src/fftw/fft3d.f90
++++ src/fftw/fft3d.f90
+@@ -40,15 +40,15 @@ module fft3d
+ type(C_PTR) :: cbuffer3
+ !! Note Franck : check if local declarations of datain/out works and improve perfs.
+ !> Field (complex values) for fftw input
+- complex(C_DOUBLE_COMPLEX), pointer :: datain1(:,:,:)=>NULL(), datain2(:,:,:)=>NULL(), datain3(:,:,:)=>NULL()
++ complex(C_FLOAT_COMPLEX), pointer :: datain1(:,:,:)=>NULL(), datain2(:,:,:)=>NULL(), datain3(:,:,:)=>NULL()
+ !> Field (real values) for fftw input (these are only pointers to the cbuffers)
+- real(C_DOUBLE), pointer :: rdatain1(:,:,:)=>NULL() ,rdatain2(:,:,:)=>NULL() ,rdatain3(:,:,:)=>NULL()
++ real(C_FLOAT), pointer :: rdatain1(:,:,:)=>NULL() ,rdatain2(:,:,:)=>NULL() ,rdatain3(:,:,:)=>NULL()
+ !> Field (real values) for fftw input in the fftw-many case
+- real(C_DOUBLE), pointer :: rdatain_many(:,:,:,:)=>NULL()
++ real(C_FLOAT), pointer :: rdatain_many(:,:,:,:)=>NULL()
+ !> Field (complex values) for fftw (forward) output
+- complex(C_DOUBLE_COMPLEX), pointer :: dataout1(:,:,:)=>NULL() ,dataout2(:,:,:)=>NULL() ,dataout3(:,:,:)=>NULL()
++ complex(C_FLOAT_COMPLEX), pointer :: dataout1(:,:,:)=>NULL() ,dataout2(:,:,:)=>NULL() ,dataout3(:,:,:)=>NULL()
+ !> Field (complex values) for fftw (forward) output in the fftw-many case
+- complex(C_DOUBLE_COMPLEX), pointer :: dataout_many(:,:,:,:)=>NULL()
++ complex(C_FLOAT_COMPLEX), pointer :: dataout_many(:,:,:,:)=>NULL()
+ !> GLOBAL number of points in each direction on which fft is applied (--> corresponds to "real" resolution - 1)
+ integer(C_INTPTR_T),pointer :: fft_resolution(:)=>NULL()
+ !> LOCAL number of points for fft
+@@ -56,15 +56,15 @@ module fft3d
+ !> Offset in the direction of distribution
+ integer(c_INTPTR_T),dimension(3) :: local_offset
+ !> wave numbers for fft in x direction
+- real(C_DOUBLE), pointer :: kx(:)
++ real(C_FLOAT), pointer :: kx(:)
+ !> wave numbers for fft in y direction
+- real(C_DOUBLE), pointer :: ky(:)
++ real(C_FLOAT), pointer :: ky(:)
+ !> wave numbers for fft in z direction
+- real(C_DOUBLE), pointer :: kz(:)
++ real(C_FLOAT), pointer :: kz(:)
+ !> log file for fftw
+ character(len=20),parameter :: filename ="parmesfftw.log"
+ !> normalization factor
+- real(C_DOUBLE) :: normFFT
++ real(C_FLOAT) :: normFFT
+ !> true if we use fftw-many routines
+ logical :: manycase
+ !> true if all the allocation stuff for global variables has been done.
+@@ -89,7 +89,7 @@ contains
+ if(is3DUpToDate) return
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+
+@@ -98,7 +98,7 @@ contains
+ fft_resolution(:) = resolution(:)-1
+
+ ! compute "optimal" size (according to fftw) for local data (warning : dimension reversal)
+- alloc_local = fftw_mpi_local_size_3d_transposed(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),main_comm,&
++ alloc_local = fftwf_mpi_local_size_3d_transposed(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),main_comm,&
+ local_resolution(c_Z),local_offset(c_Z),local_resolution(c_Y),local_offset(c_Y));
+
+ ! Set a default value for c_X components.
+@@ -106,35 +106,35 @@ contains
+ local_resolution(c_X) = fft_resolution(c_X)
+
+ ! allocate local buffer (used to save datain/dataout ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
+ ! link datain and dataout to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, datain1, [fft_resolution(c_X),fft_resolution(c_Y),local_resolution(c_Z)])
+ call c_f_pointer(cbuffer1, dataout1, [fft_resolution(c_X),fft_resolution(c_Z),local_resolution(c_Y)])
+
+ ! second buffer used for backward transform. Used to copy dataout into dataout2 (input for backward transform and filter)
+ ! and to save (in-place) the transform of the second component of the velocity
+- cbuffer2 = fftw_alloc_complex(alloc_local)
++ cbuffer2 = fftwf_alloc_complex(alloc_local)
+ call c_f_pointer(cbuffer2, datain2, [fft_resolution(c_X),fft_resolution(c_Y),local_resolution(c_Z)])
+ call c_f_pointer(cbuffer2, dataout2, [fft_resolution(c_X),fft_resolution(c_Z),local_resolution(c_Y)])
+
+ ! second buffer used for backward transform. Used to copy dataout into dataout2 (input for backward transform and filter)
+ ! and to save (in-place) the transform of the second component of the velocity
+- cbuffer3 = fftw_alloc_complex(alloc_local)
++ cbuffer3 = fftwf_alloc_complex(alloc_local)
+ call c_f_pointer(cbuffer3, datain3, [fft_resolution(c_X),fft_resolution(c_Y),local_resolution(c_Z)])
+ call c_f_pointer(cbuffer3, dataout3, [fft_resolution(c_X),fft_resolution(c_Z),local_resolution(c_Y)])
+
+ ! create MPI plan for in-place forward/backward DFT (note dimension reversal)
+- plan_forward1 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain1,dataout1,&
++ plan_forward1 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain1,dataout1,&
+ main_comm,FFTW_FORWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout1,datain1,&
++ plan_backward1 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout1,datain1,&
+ main_comm,FFTW_BACKWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_forward2 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain2,dataout2,&
++ plan_forward2 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain2,dataout2,&
+ main_comm,FFTW_FORWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward2 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout2,datain2,&
++ plan_backward2 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout2,datain2,&
+ main_comm,FFTW_BACKWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_forward3 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain3,dataout3,&
++ plan_forward3 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z), fft_resolution(c_Y), fft_resolution(c_X),datain3,dataout3,&
+ main_comm,FFTW_FORWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward3 = fftw_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout3,datain3,&
++ plan_backward3 = fftwf_mpi_plan_dft_3d(fft_resolution(c_Z),fft_resolution(c_Y),fft_resolution(c_X),dataout3,datain3,&
+ main_comm,FFTW_BACKWARD,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+
+ call computeKx(lengths(c_X))
+@@ -173,17 +173,17 @@ contains
+ end do
+ end do
+ ! compute transform (as many times as desired)
+- call fftw_mpi_execute_dft(plan_forward1, datain1, dataout1)
+- call fftw_mpi_execute_dft(plan_forward2, datain2, dataout2)
+- call fftw_mpi_execute_dft(plan_forward3, datain3, dataout3)
++ call fftwf_mpi_execute_dft(plan_forward1, datain1, dataout1)
++ call fftwf_mpi_execute_dft(plan_forward2, datain2, dataout2)
++ call fftwf_mpi_execute_dft(plan_forward3, datain3, dataout3)
+
+ ! apply poisson filter
+ call filter_poisson_3d()
+
+ ! inverse transform to retrieve velocity
+- call fftw_mpi_execute_dft(plan_backward1, dataout1,datain1)
+- call fftw_mpi_execute_dft(plan_backward2,dataout2,datain2)
+- call fftw_mpi_execute_dft(plan_backward3,dataout3,datain3)
++ call fftwf_mpi_execute_dft(plan_backward1, dataout1,datain1)
++ call fftwf_mpi_execute_dft(plan_backward2,dataout2,datain2)
++ call fftwf_mpi_execute_dft(plan_backward3,dataout3,datain3)
+ do k =1, local_resolution(c_Z)
+ do j = 1, fft_resolution(c_Y)
+ do i = 1, fft_resolution(c_X)
+@@ -213,7 +213,7 @@ contains
+ if(is3DUpToDate) return
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+ allocate(fft_resolution(3))
+@@ -221,7 +221,7 @@ contains
+ halfLength = fft_resolution(c_X)/2+1
+
+ ! compute "optimal" size (according to fftw) for local data (warning : dimension reversal)
+- alloc_local = fftw_mpi_local_size_3d_transposed(fft_resolution(c_Z),fft_resolution(c_Y),halfLength,&
++ alloc_local = fftwf_mpi_local_size_3d_transposed(fft_resolution(c_Z),fft_resolution(c_Y),halfLength,&
+ main_comm,local_resolution(c_Z),local_offset(c_Z),local_resolution(c_Y),local_offset(c_Y));
+
+ ! init c_X part. This is required to compute kx with the same function in 2d and 3d cases.
+@@ -229,9 +229,9 @@ contains
+ local_resolution(c_X) = halfLength
+
+ ! allocate local buffer (used to save datain/dataout ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
+- cbuffer2 = fftw_alloc_complex(alloc_local)
+- cbuffer3 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
++ cbuffer2 = fftwf_alloc_complex(alloc_local)
++ cbuffer3 = fftwf_alloc_complex(alloc_local)
+
+ ! link rdatain and dataout to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, rdatain1, [2*halfLength,fft_resolution(c_Y),local_resolution(c_Z)])
+@@ -246,17 +246,17 @@ contains
+ rdatain3 = 0.0
+
+ ! create MPI plans for in-place forward/backward DFT (note dimension reversal)
+- plan_forward1 = fftw_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain1, dataout1, &
++ plan_forward1 = fftwf_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain1, dataout1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
++ plan_backward1 = fftwf_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout1, rdatain1, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_forward2 = fftw_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain2, dataout2, &
++ plan_forward2 = fftwf_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain2, dataout2, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward2 = fftw_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
++ plan_backward2 = fftwf_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout2, rdatain2, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+- plan_forward3 = fftw_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain3, dataout3, &
++ plan_forward3 = fftwf_mpi_plan_dft_r2c_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), rdatain3, dataout3, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward3 = fftw_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout3, rdatain3, &
++ plan_backward3 = fftwf_mpi_plan_dft_c2r_3d(fft_resolution(c_Z),fft_resolution(c_Y), fft_resolution(c_X), dataout3, rdatain3, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+
+ call computeKx(lengths(c_X))
+@@ -279,7 +279,7 @@ contains
+
+ real(mk),dimension(:,:,:),intent(in) :: omega_x,omega_y,omega_z
+ integer, dimension(3), intent(in) :: ghosts
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k, ig, jg, kg
+
+ ! ig, jg, kg are used to take into account
+@@ -301,9 +301,9 @@ contains
+
+ ! compute transforms for each component
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
+- call fftw_mpi_execute_dft_r2c(plan_forward2, rdatain2, dataout2)
+- call fftw_mpi_execute_dft_r2c(plan_forward3, rdatain3, dataout3)
++ call fftwf_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
++ call fftwf_mpi_execute_dft_r2c(plan_forward2, rdatain2, dataout2)
++ call fftwf_mpi_execute_dft_r2c(plan_forward3, rdatain3, dataout3)
+ !!print *, "r2c time = ", MPI_WTIME() - start
+
+ end subroutine r2c_3d
+@@ -316,12 +316,12 @@ contains
+ subroutine c2r_3d(velocity_x,velocity_y,velocity_z, ghosts)
+ real(mk),dimension(:,:,:),intent(inout) :: velocity_x,velocity_y,velocity_z
+ integer, dimension(3), intent(in) :: ghosts
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k, ig, jg, kg
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
+- call fftw_mpi_execute_dft_c2r(plan_backward2,dataout2,rdatain2)
+- call fftw_mpi_execute_dft_c2r(plan_backward3,dataout3,rdatain3)
++ call fftwf_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
++ call fftwf_mpi_execute_dft_c2r(plan_backward2,dataout2,rdatain2)
++ call fftwf_mpi_execute_dft_c2r(plan_backward3,dataout3,rdatain3)
+ !! print *, "c2r time : ", MPI_WTIME() -start
+ ! copy back to velocity and normalisation
+ do k =1, local_resolution(c_Z)
+@@ -346,7 +346,7 @@ contains
+
+ real(mk),dimension(:,:,:),intent(in) :: omega
+ integer, dimension(3), intent(in) :: ghosts
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k, ig, jg, kg
+
+ ! ig, jg, kg are used to take into account
+@@ -366,7 +366,7 @@ contains
+
+ ! compute transforms for each component
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
++ call fftwf_mpi_execute_dft_r2c(plan_forward1, rdatain1, dataout1)
+ !!print *, "r2c time = ", MPI_WTIME() - start
+
+ end subroutine r2c_scalar_3d
+@@ -377,10 +377,10 @@ contains
+ subroutine c2r_scalar_3d(omega, ghosts)
+ real(mk),dimension(:,:,:),intent(inout) :: omega
+ integer, dimension(3), intent(in) :: ghosts
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k, ig, jg, kg
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
++ call fftwf_mpi_execute_dft_c2r(plan_backward1,dataout1,rdatain1)
+ !! print *, "c2r time : ", MPI_WTIME() -start
+ ! copy back to velocity and normalisation
+ do k =1, local_resolution(c_Z)
+@@ -412,7 +412,7 @@ contains
+ integer(C_INTPTR_T),dimension(3) :: n
+
+ ! init fftw mpi context
+- call fftw_mpi_init()
++ call fftwf_mpi_init()
+ blocksize = FFTW_MPI_DEFAULT_BLOCK
+ if(rank==0) open(unit=21,file=filename,form="formatted")
+ allocate(fft_resolution(3))
+@@ -423,7 +423,7 @@ contains
+ n(3) = halfLength
+ howmany = 3
+ ! compute "optimal" size (according to fftw) for local data (warning : dimension reversal)
+- alloc_local = fftw_mpi_local_size_many_transposed(3,n,howmany,blocksize,blocksize,&
++ alloc_local = fftwf_mpi_local_size_many_transposed(3,n,howmany,blocksize,blocksize,&
+ main_comm,local_resolution(c_Z),local_offset(c_Z),local_resolution(c_Y),local_offset(c_Y));
+
+ ! init c_X part. This is required to compute kx with the same function in 2d and 3d cases.
+@@ -431,7 +431,7 @@ contains
+ local_resolution(c_X) = halfLength
+
+ ! allocate local buffer (used to save datain/dataout ==> in-place transform!!)
+- cbuffer1 = fftw_alloc_complex(alloc_local)
++ cbuffer1 = fftwf_alloc_complex(alloc_local)
+
+ ! link rdatain and dataout to cbuffer, setting the right dimensions for each
+ call c_f_pointer(cbuffer1, rdatain_many, [howmany,2*halfLength,fft_resolution(c_Y),local_resolution(c_Z)])
+@@ -440,9 +440,9 @@ contains
+ ! create MPI plans for in-place forward/backward DFT (note dimension reversal)
+ n(3) = fft_resolution(c_X)
+
+- plan_forward1 = fftw_mpi_plan_many_dft_r2c(3,n,howmany,blocksize,blocksize, rdatain_many, dataout_many, &
++ plan_forward1 = fftwf_mpi_plan_many_dft_r2c(3,n,howmany,blocksize,blocksize, rdatain_many, dataout_many, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_OUT))
+- plan_backward1 = fftw_mpi_plan_many_dft_c2r(3,n,howmany,blocksize,blocksize, dataout_many, rdatain_many, &
++ plan_backward1 = fftwf_mpi_plan_many_dft_c2r(3,n,howmany,blocksize,blocksize, dataout_many, rdatain_many, &
+ main_comm,ior(FFTW_MEASURE,FFTW_MPI_TRANSPOSED_IN))
+ call computeKx(lengths(c_X))
+ call computeKy(lengths(c_Y))
+@@ -464,7 +464,7 @@ contains
+ subroutine r2c_3d_many(omega_x,omega_y,omega_z)
+
+ real(mk),dimension(:,:,:),intent(in) :: omega_x,omega_y,omega_z
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k
+
+ ! init
+@@ -480,7 +480,7 @@ contains
+
+ ! compute transform (as many times as desired)
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_r2c(plan_forward1, rdatain_many, dataout_many)
++ call fftwf_mpi_execute_dft_r2c(plan_forward1, rdatain_many, dataout_many)
+ !! print *, "r2c time = ", MPI_WTIME() - start
+
+ end subroutine r2c_3d_many
+@@ -491,11 +491,11 @@ contains
+ !! @param[in,out] velocity_z 3d scalar field, z-component of the output vector field
+ subroutine c2r_3d_many(velocity_x,velocity_y,velocity_z)
+ real(mk),dimension(:,:,:),intent(inout) :: velocity_x,velocity_y,velocity_z
+- real(mk) :: start
++ real(8) :: start
+ integer(C_INTPTR_T) :: i,j,k
+
+ start = MPI_WTIME()
+- call fftw_mpi_execute_dft_c2r(plan_backward1,dataout_many,rdatain_many)
++ call fftwf_mpi_execute_dft_c2r(plan_backward1,dataout_many,rdatain_many)
+ !! print *, "c2r time : ", MPI_WTIME() -start
+ do k =1, local_resolution(c_Z)
+ do j = 1, fft_resolution(c_Y)
+@@ -536,7 +536,7 @@ contains
+ !> Computation of frequencies coeff, over distributed direction(s)
+ !> @param lengths size of the domain
+ subroutine computeKy(length)
+- real(C_DOUBLE), intent(in) :: length
++ real(C_FLOAT), intent(in) :: length
+
+ !! Local loops indices
+ integer(C_INTPTR_T) :: i
+@@ -589,8 +589,8 @@ contains
+ subroutine filter_poisson_3d()
+
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2
+
+ ! Set first coeff (check for "all freq = 0" case)
+ if(local_offset(c_Y) == 0) then
+@@ -648,10 +648,10 @@ contains
+ !! @param[in] nudt \f$ \nu\times dt\f$, diffusion coefficient times current time step
+ subroutine filter_curl_diffusion_3d(nudt)
+
+- real(C_DOUBLE), intent(in) :: nudt
++ real(C_FLOAT), intent(in) :: nudt
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2
+
+ !! mind the transpose -> index inversion between y and z
+ do j = 1,local_resolution(c_Y)
+@@ -674,9 +674,9 @@ contains
+ !! @param[in] nudt \f$ \nu\times dt\f$, diffusion coefficient times current time step
+ subroutine filter_diffusion_3d(nudt)
+
+- real(C_DOUBLE), intent(in) :: nudt
++ real(C_FLOAT), intent(in) :: nudt
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: coeff
+
+ !! mind the transpose -> index inversion between y and z
+ do j = 1,local_resolution(c_Y)
+@@ -697,8 +697,8 @@ contains
+ subroutine filter_curl_3d()
+
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2
+
+ !! mind the transpose -> index inversion between y and z
+ do j = 1,local_resolution(c_Y)
+@@ -721,8 +721,8 @@ contains
+ subroutine filter_projection_om_3d()
+
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2,buffer3
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2,buffer3
+
+ ! Set first coeff (check for "all freq = 0" case)
+ if(local_offset(c_Y) == 0) then
+@@ -783,9 +783,9 @@ contains
+ !! @param[in] dxf, dyf, dzf: grid filter size = domainLength/(CoarseRes-1)
+ subroutine filter_multires_om_3d(dxf, dyf, dzf)
+
+- real(C_DOUBLE), intent(in) :: dxf, dyf, dzf
++ real(C_FLOAT), intent(in) :: dxf, dyf, dzf
+ integer(C_INTPTR_T) :: i,j,k
+- real(C_DOUBLE) :: kxc, kyc, kzc
++ real(C_FLOAT) :: kxc, kyc, kzc
+
+ kxc = pi / dxf
+ kyc = pi / dyf
+@@ -810,7 +810,7 @@ contains
+ !! pressure from velocity in the Fourier space
+ subroutine filter_pressure_3d()
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: coeff
+
+ ! Set first coeff (check for "all freq = 0" case)
+ if(local_offset(c_Y) == 0) then
+@@ -851,8 +851,8 @@ contains
+ subroutine filter_poisson_3d_many()
+
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2
+
+ ! Set first coeff (check for "all freq = 0" case)
+ if(local_offset(c_Y) == 0) then
+@@ -908,10 +908,10 @@ contains
+ !! @param[in] nudt \f$ \nu\times dt\f$, diffusion coefficient times current time step
+ subroutine filter_diffusion_3d_many(nudt)
+
+- real(C_DOUBLE), intent(in) :: nudt
++ real(C_FLOAT), intent(in) :: nudt
+ integer(C_INTPTR_T) :: i,j,k
+- complex(C_DOUBLE_COMPLEX) :: coeff
+- complex(C_DOUBLE_COMPLEX) :: buffer1,buffer2
++ complex(C_FLOAT_COMPLEX) :: coeff
++ complex(C_FLOAT_COMPLEX) :: buffer1,buffer2
+
+ !! mind the transpose -> index inversion between y and z
+ do j = 1,local_resolution(c_Y)
+@@ -931,18 +931,18 @@ contains
+
+ !> Clean fftw context (free memory, plans ...)
+ subroutine cleanFFTW_3d()
+- call fftw_destroy_plan(plan_forward1)
+- call fftw_destroy_plan(plan_backward1)
++ call fftwf_destroy_plan(plan_forward1)
++ call fftwf_destroy_plan(plan_backward1)
+ if(.not.manycase) then
+- call fftw_destroy_plan(plan_forward2)
+- call fftw_destroy_plan(plan_backward2)
+- call fftw_destroy_plan(plan_forward3)
+- call fftw_destroy_plan(plan_backward3)
+- call fftw_free(cbuffer2)
+- call fftw_free(cbuffer3)
++ call fftwf_destroy_plan(plan_forward2)
++ call fftwf_destroy_plan(plan_backward2)
++ call fftwf_destroy_plan(plan_forward3)
++ call fftwf_destroy_plan(plan_backward3)
++ call fftwf_free(cbuffer2)
++ call fftwf_free(cbuffer3)
+ endif
+- call fftw_free(cbuffer1)
+- call fftw_mpi_cleanup()
++ call fftwf_free(cbuffer1)
++ call fftwf_mpi_cleanup()
+ deallocate(fft_resolution)
+ deallocate(kx,ky,kz)
+ if(rank==0) close(21)
+@@ -953,7 +953,7 @@ contains
+ integer(C_INTPTR_T), intent(in) :: nbelem
+ ! number of buffers used for fftw
+ integer, optional,intent(in) :: howmany
+- complex(C_DOUBLE_COMPLEX) :: memoryAllocated
++ complex(C_FLOAT_COMPLEX) :: memoryAllocated
+
+ integer :: nbFields
+ if(present(howmany)) then
+diff --git src/main/main.f90 src/main/main.f90
+index 38cc6a5..0fc8f5f 100755
+--- src/main/main.f90
++++ src/main/main.f90
+@@ -9,7 +9,7 @@ use vectorcalculus
+ implicit none
+
+ integer :: info
+-real(mk) :: start, end
++real(8) :: start, end
+
+ !complex(mk), dimension(resolution(1),resolution(2)) :: omega,velocity_x,velocity_y
+ call MPI_Init(info)
+@@ -116,7 +116,8 @@ contains
+ real(mk),dimension(3) :: lengths,step
+ integer, dimension(3) :: ghosts_v, ghosts_w
+ integer(C_INTPTR_T),dimension(3) :: nfft,offset
+- real(mk) :: error,start
++ real(mk) :: error
++ real(8) :: start
+ logical :: ok
+
+ if (rank==0) print *, " ======= Test 3D Poisson (r2c) solver for resolution ", resolution
+diff --git src/scalesInterface/precision_tools.f90 src/scalesInterface/precision_tools.f90
+index 5dacf3f..4ae1a6a 100644
+--- src/scalesInterface/precision_tools.f90
++++ src/scalesInterface/precision_tools.f90
+@@ -20,15 +20,15 @@
+ !------------------------------------------------------------------------------
+
+ MODULE precision_tools
+- use mpi, only: MPI_DOUBLE_PRECISION
++ use mpi, only: MPI_REAL
+ implicit None
+
+ !> Floats precision
+ INTEGER, PARAMETER :: SP = kind(1.0)
+ INTEGER, PARAMETER :: DP = kind(1.0d0)
+- INTEGER, PARAMETER :: WP = DP
++ INTEGER, PARAMETER :: WP = SP
+ !> the MPI type for REAL exchanges in simple or double precision
+- INTEGER, parameter :: MPI_REAL_WP = MPI_DOUBLE_PRECISION
++ INTEGER, parameter :: MPI_REAL_WP = MPI_REAL
+ REAL(WP), PRIVATE :: sample_real_at_WP
+ REAL(WP), PARAMETER :: MAX_REAL_WP = HUGE(sample_real_at_WP)
+ INTEGER, PRIVATE :: sample_int
diff --git a/HySoP/hysop/domain/obstacle/__init__.py b/HySoP/hysop/domain/obstacle/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..be5911bbcc91dc597c5c18e7479042e779dfd672
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/__init__.py
@@ -0,0 +1,57 @@
+## @package parmepy.domain.obstacle
+# Obstacles description (geometry).
+#
+#
+# An 'obstacle' is the description of a sub-domain
+# of the main physical domain with one or more user-defined
+# functions of the space coordinates (at least).
+#
+# What for? \n
+# Mainly to provide some 'index sets' to penalization operator.\n
+# For a given obstacle, and a given discrete field, we must be able to call:
+# \code
+# cond = obstacle.discretize(topo)
+# field[cond] = 1.9
+# \endcode
+# This example means that the field (discretized on topology topo)
+# will be set to 1.9 everywhere inside the obstacle.
+#
+#
+# Obviouslvy the index sets will depend on the discretization
+# of the domain (the underlying topology indeed).
+# So each obstacle handles a dictionnary of boolean arrays. The keys
+# of the dictionnaries are the topologies and the values some boolean arrays
+# which values are true on and inside the object and false outside.
+# \code
+# obstacle.ind[topo] = someBooleanArray
+# \endcode
+# Each component of the dictionnary is created using the method 'discretize':
+# \code
+# # Create the boolean array that represents the obstacle for topology topo:
+# someBooleanArray = obstacle.discretize(topo)
+# # So for a field already discretized on topo, we may call
+# field[someBooleanArray]
+# \endcode
+#
+# A more complete example : initialize a scalar field with one inside a sphere
+# and zero everywhere else.
+#
+# \code
+# Lx = Ly = Lz = 2
+# dom = pp.Box(dimension=3, length=[Lx, Ly, Lz], origin=[-1., -1., -1.])
+# # Definition of a sphere in the middle of the domain
+# sphere = Sphere(dom, position=[0., 0., 0.], radius=0.5)
+# # A topology
+# topo = Cartesian(dom, 3, [33, 33, 33])
+# # A scalar field on the domain :
+# scal = pp.Field(domain=dom, name='Scalar')
+# # Discretization on topo:
+# scal_discr = scal.discretize(topo)
+# # scal set to 1. inside the obstacle:
+# condition = sphere.discretize(topo)
+# scal.discreteFields[topo][condition] = 1.
+# # equivalent to
+# scal_discr[condition] = 1.
+# # to set a value everywhere except in the sphere
+# scal_discr[not condition] = 8.
+# \endcode
diff --git a/HySoP/hysop/domain/obstacle/controlBox.py b/HySoP/hysop/domain/obstacle/controlBox.py
new file mode 100644
index 0000000000000000000000000000000000000000..9e5c7cc24761399930bd7053be3b7334bf681acd
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/controlBox.py
@@ -0,0 +1,296 @@
+"""
+@file controlBox.py
+Define a sub-domain with a box-liked shape.
+"""
+from parmepy.domain.obstacle.obstacle import Obstacle
+from parmepy.domain.obstacle.planes import SubSpace, SubPlane
+from parmepy.mpi.mesh import SubMesh
+import numpy as np
+import parmepy.tools.numpywrappers as npw
+
+
+class ControlBox(Obstacle):
+ """
+ Build a sub-domain, box-shaped
+ ==> define set of indices inside this domain (ind member)
+ and set of indices belonging to surfaces of this domain (slices members).
+ Useful to define control volume to perform integration.
+ See for example parmepy.operator.monitor.forces
+ """
+
+ def __init__(self, origin, lengths, **kwds):
+ """
+ Build the volume of control
+ @param origin : coordinates of the lowest point in the sub-domain
+ @param lengths : lengths of box sides.
+ """
+ super(ControlBox, self).__init__(**kwds)
+
+ ## Lowest point of the box
+ self.origin = npw.realarray(origin)
+ ## Box's sides dimension
+ self.lengths = npw.realarray(lengths)
+ ## Dictionnary of local meshes, such that
+ ## mesh[topo] is the restriction of topo.mesh
+ ## to the current control box.
+ self.mesh = {}
+ self.upper = None
+ self.lower = None
+ self.upperS = None
+ self.lowerS = None
+ self.slices = {}
+ self.indReduced = {}
+ self._boxCreated = False
+ ## Check if the defined box contains points
+ ## for a given topology. self.isEmpty[topo] = False
+ ## if some grid points are inside the box on
+ ## the current processor for topo discretization.
+ self.isEmpty = {}
+ ## Dict of local coordinates for a given topology
+ self.coords = {}
+ ## Global resolution of the obstacle (plane, sub space ...)
+ ## At the time, it's computed only for subspaces, by calling
+ ## globalResolution method.
+ self.gRes = None
+ ## Global index in the original topology of the 'lowest' point
+ ## of the obstacle. Only for subspaces.
+ self.gstart = None
+
+ def createVolumeAndSides(self, spaceStep):
+ """
+ @param[in] array of size self._dim, space step size in each direction
+ This value will be used to compute a tolerance and detect
+ points inside the box.
+ """
+ # Build Half-spaces indices list in all directions
+ normalUp = np.identity(self._dim)
+ normalDown = np.identity(self._dim) * -1.
+ pointsUp = npw.zeros((self._dim, self._dim))
+ # Control box will be used for integration, so we remove the
+ # last point in the grid.
+ boxlengths = self.lengths - spaceStep
+ tol = spaceStep * 0.5
+
+ for i in xrange(self._dim):
+ pointsUp[:, i] = self.origin
+ pointsUp.flat[::self._dim + 1] += self.lengths
+ # -- Control volume : union of two halfspaces --
+ if self.upper is None:
+ self.upper = [SubSpace(domain=self.domain, normal=normalUp[:, i],
+ point=pointsUp[:, i],
+ lengths=boxlengths,
+ epsilon=tol[i])
+ for i in xrange(self._dim)]
+ if self.lower is None:
+ self.lower = [SubSpace(domain=self.domain, normal=normalDown[:, i],
+ point=self.origin, lengths=boxlengths,
+ epsilon=tol[i])
+ for i in xrange(self._dim)]
+
+ # Create objects to describe the sides of the box
+ if self.upperS is None:
+ self.upperS = [SubPlane(domain=self.domain, normal=normalUp[:, i],
+ point=pointsUp[:, i],
+ lengths=boxlengths,
+ epsilon=tol[i])
+ for i in xrange(self._dim)]
+
+ if self.lowerS is None:
+ self.lowerS = [SubPlane(domain=self.domain, normal=normalDown[:, i],
+ point=self.origin, lengths=boxlengths,
+ epsilon=tol[i])
+ for i in xrange(self._dim)]
+ self._boxCreated = True
+
+ def discretize(self, topo):
+ """
+ Discretize the box volume and its surfaces.
+ @param topo : the topology that described the discretization.
+ """
+ # Check if already done. If so, this function has no effect.
+ if topo not in self.ind.keys():
+ spaceStep = topo.mesh.space_step
+ # -- Control volume : union of two halfspaces --
+ if not self._boxCreated:
+ self.createVolumeAndSides(spaceStep)
+
+ # Discretize all volume and surfaces of
+ # the box for topo
+ for i in xrange(self._dim):
+ self.lower[i].discretize(topo)
+ self.upper[i].discretize(topo)
+ self.lowerS[i].discretize(topo)
+ self.upperS[i].discretize(topo)
+
+ # 1 -- Compute list of indices inside the box,
+ # for topo --> ind[topo]
+ self.ind[topo] = []
+
+ self.ind[topo].append(np.logical_and(self.upper[0].ind[topo][0],
+ self.lower[0].ind[topo][0]))
+ for i in xrange(1, self._dim):
+ cond = np.logical_and(self.upper[i].ind[topo][0],
+ self.lower[i].ind[topo][0])
+ self.ind[topo][0] = np.logical_and(self.ind[topo][0], cond)
+
+ ind = np.where(self.ind[topo][0])
+
+ # 2 -- Convert ind[topo] (array of bool) to slices
+ # which may be more convenient for computations
+ # --> slices[topo]
+ # + mesh[topo], a parmepy.mpi.SubMesh, useful
+ # to get local coordinates and so on
+ if ind[0].size == 0:
+ self.slices[topo] = [slice(0, 0) for i in xrange(self._dim)]
+ self.mesh[topo] = None
+ self.isEmpty[topo] = True
+ else:
+ self.isEmpty[topo] = False
+ ic = topo.mesh.iCompute
+ lstart = [ind[i].min() if ind[i].size > 0 else None
+ for i in xrange(self._dim)]
+ lstart = npw.integerarray([max(lstart[i], ic[i].start)
+ for i in xrange(self._dim)])
+ end = [ind[i].max() for i in xrange(self._dim)]
+ end = npw.integerarray([min(end[i], ic[i].stop - 1)
+ for i in xrange(self._dim)])
+ # slice(start,end) --> end not included, so +1
+ end += 1
+ resol = end - lstart + 2 * topo.ghosts
+ gstart = lstart + topo.mesh.global_start - topo.ghosts
+ self.mesh[topo] = SubMesh(topo, gstart, resol)
+ self.slices[topo] = [slice(lstart[i], end[i])
+ for i in xrange(self._dim)]
+ coords = []
+ for i in xrange(self._dim):
+ cc = topo.mesh.coords[i].flat[self.slices[topo][i]]
+ coords.append(cc)
+ coords = tuple(coords)
+ self.coords[topo] = np.ix_(*coords)
+
+ # --> self.ind[topo][0] components are True
+ # for points inside the volume
+ # --> self.slices[topo] represent the same thing
+ # but using slices of numpy arrays.
+ # Usage (vd being a numpy array discretized
+ # on the whole domain, cb a control box):
+ # # Set values to all points inside the control box
+ # vd[cb.ind[topo][0]] = ...
+ # # Get a sub-array of vd representing the control box
+ # # and use it
+ # result[...] = vd[cb.slices] + ...
+ # The important difference between slices and ind is:
+ # 1 - vd[ind] returns a 1D array whatever vd shape is.
+ # 2 - vd[slices] return an array of the same dim as vd,
+ # with shape given by slices.
+
+ return self.ind[topo]
+
+ def sub(self, obstacle, topo):
+ """
+ Remove all points corresponding to the input obstacle from
+ the current control box
+ """
+ if topo not in self.ind.keys():
+ obstacle.discretize(topo)
+ self.discretize(topo)
+ self.indReduced[topo] = []
+ # Warning : obstacle may have several layers
+ cond = obstacle.ind[topo][0]
+ for i in xrange(1, len(obstacle.ind[topo])):
+ cond = npw.asarray(np.logical_or(cond, obstacle.ind[topo][i]))
+ cond = np.logical_not(cond)
+ self.indReduced[topo].append(np.logical_and(self.ind[topo][0],
+ cond))
+ return self.indReduced[topo][-1]
+
+ def integrate_on_proc(self, field, topo, useSlice=True, component=0):
+ """
+ integrate field on the box
+ """
+ if useSlice:
+ cond = self.slices[topo]
+ else:
+ iC = topo.mesh.iCompute
+ cond = self.ind[topo][0][iC]
+ dvol = npw.prod(topo.mesh.space_step)
+ result = npw.sum(field.discretize(topo)[component][cond])
+ result *= dvol
+ return result
+
+ def integrate(self, field, topo, useSlice=True,
+ component=0, root=0, mpiall=True):
+ res = self.integrate_on_proc(field, topo, useSlice, component)
+ if mpiall:
+ return topo.comm.allreduce(res)
+ else:
+ return topo.comm.reduce(res, root=root)
+
+ def integrateOnSurface(self, field, topo, normalDir=0, up=True,
+ useSlice=True, component=0, root=0, mpiall=True):
+ """
+ integrate field on top (if up is True) or down surface
+ normal to a direction
+ """
+ res = self.integrateOnSurf_proc(field, topo, normalDir, up, useSlice,
+ component)
+ if mpiall:
+ return topo.comm.allreduce(res)
+ else:
+ return topo.comm.reduce(res, root=root)
+
+ def integrateOnSurf_proc(self, field, topo, normalDir=0,
+ up=True, useSlice=True, component=0):
+ """
+ integrate field on top and down surfaces normal to a direction
+ """
+ if up:
+ surf = self.upperS[normalDir]
+ else:
+ surf = self.lowerS[normalDir]
+ if useSlice:
+ cond = surf.slices[topo]
+ else:
+ iC = topo.mesh.iCompute
+ cond = surf.ind[topo][0][iC]
+ dirs = np.logical_not(np.arange(self._dim) == normalDir)
+ dS = npw.prod(topo.mesh.space_step[dirs])
+ result = npw.sum(field.discretize(topo)[component][cond])
+ result *= dS
+ return result
+
+ def globalResolution(self, parent_topo):
+ """
+ Compute 'global resolution' of the subplane
+ """
+ # We create a false topology, with only one proc
+ # to get the global resolution for the plane.
+ # This could also be done with local computation
+ # sum but that would need a lot of communications.
+ if parent_topo.rank == 0:
+ color = 0
+ else:
+ color = 1
+ subcomm = parent_topo.comm.Split(color)
+ dimension = self.domain.dimension
+ tmp = None
+ if parent_topo.rank == 0:
+ resolution = parent_topo.globalMeshResolution
+ ghosts = parent_topo.ghosts
+ topo = self.domain.getOrCreateTopology(3, resolution,
+ ghosts=ghosts, comm=subcomm)
+ self.discretize(topo)
+ sl = self.slices[topo]
+ self.gRes = [sl[i].stop - sl[i].start for i in xrange(dimension)]
+ self.gstart = [sl[i].start for i in xrange(dimension)]
+ # if the topology has been created just to
+ # get the global resolution, we can remove it
+ if topo.isNew:
+ self.domain.remove(topo)
+ self.slices.pop(topo)
+ self.ind.pop(topo)
+ tmp = self.gRes + self.gstart
+ tmp = parent_topo.comm.bcast(tmp)
+ self.gRes = tmp[:dimension]
+ self.gstart = tmp[dimension:]
+ return self.gRes
diff --git a/HySoP/hysop/domain/obstacle/disk.py b/HySoP/hysop/domain/obstacle/disk.py
new file mode 100644
index 0000000000000000000000000000000000000000..f57cbcc9284fac1aeab3a38190cc1b8f8490694e
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/disk.py
@@ -0,0 +1,64 @@
+"""
+@file disk.py
+Rigid disk (2D)
+"""
+from parmepy.domain.obstacle.sphere import Sphere, HemiSphere
+import numpy as np
+import parmepy.tools.numpywrappers as npw
+
+
+class Disk(Sphere):
+ """
+ Disk in a 2D domain.
+ """
+
+ def __init__(self, **kwds):
+ """
+ Description of a disk in a domain.
+ @param domain : the physical domain that contains the sphere.
+ @param position : position of the center
+ @param radius : sphere radius, default = 1
+ @param porousLayers : a list of thicknesses
+ for successive porous layers
+ radius is the inside sphere radius and thicknesses are given from
+ inside layer to outside one.
+ @param vd : velocity of the disk (considered as a rigid body),
+ default = 0.
+ """
+ super(Disk, self).__init__(**kwds)
+ assert self.domain.dimension == 2
+
+ def dist(x, y, R):
+ return npw.asarray(np.sqrt((x - self.position[0]) ** 2
+ + (y - self.position[1]) ** 2) - R)
+ self.chi = [dist]
+
+
+class HalfDisk(HemiSphere):
+ """
+ Half disk in a 2D domain.
+ """
+ def __init__(self, **kwds):
+ """
+ Constructor for the semi-disk.
+ @param domain : the physical domain that contains the sphere.
+ @param position : position of the center
+ @param radius : sphere radius, default = 1
+ (if box ...)
+ @param vd : velocity of the disk (considered as a rigid body),
+ default = 0.
+ """
+ super(HalfDisk, self).__init__(**kwds)
+ assert self.domain.dimension == 2
+
+ def dist(x, y, R):
+ """
+ """
+ return npw.asarray(np.sqrt((x - self.position[0]) ** 2
+ + (y - self.position[1]) ** 2) - R)
+ self.chi = [dist]
+
+ def LeftBox(x, y):
+ return x - self.position[0]
+
+ self.LeftBox = LeftBox
diff --git a/HySoP/hysop/domain/obstacle/obstacle.py b/HySoP/hysop/domain/obstacle/obstacle.py
new file mode 100644
index 0000000000000000000000000000000000000000..c052ed7aa218ec544d66958a060d55611592a888
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/obstacle.py
@@ -0,0 +1,96 @@
+"""@file obstacle.py
+
+General interface to define a new geometry
+inside a domain (sphere, control box ...)
+"""
+import numpy as np
+
+
+class Obstacle(object):
+ """Ddescription of a physical obstacle.
+ An obstacle is the geometrical description of
+ a physical sub-domain.
+ """
+ def __init__(self, domain, formula=None, vd=0.0):
+ """ Constructor
+ @param domain : the domain that contains this obstacle.
+ @param formula : a list of functions that describe
+ the geometry of the obstacle.
+ @param vd : velocity of the obstacle (considered as a rigid body),
+ default = 0.
+ """
+ ## Domain.
+ self.domain = domain
+ from parmepy.domain.box import Box
+ assert isinstance(domain, Box),\
+ 'Obstacle only implemented for box-like domains'
+ ## Obstacle dimension.
+ self._dim = domain.dimension
+ ## A function that describe the geometry of the obstacle.
+ ## see parmepy.domain.obstacle.
+ self.chi = []
+ if formula is not None:
+ if isinstance(formula, list):
+ for func in formula:
+ self.chi.append = np.vectorize(func)
+ else:
+ self.chi = [np.vectorize(formula)]
+ ## A dictionnary of lists of indices ...
+ ## ind[topo][i] represents the set of points of the domain
+ ## discretized with topo that are in the area defined with chi[i].
+ self.ind = {}
+ ## Velocity of the center of mass of the obstacle
+ ## (considered as a rigid body)
+ self.vd = vd
+ ## Check if some grid points are present inside the current object
+ ## for the current mpi proc. If not, isEmpty[topo] = True.
+ self.isEmpty = {}
+
+
+ def discretize(self, topo):
+ """
+ For a given topology, computes the list of points in the domain
+ that belongs to the obstacle.
+ Add a new index into self.indices.
+ @param topo : topology specification for discretization
+ @return an array of bool such that array[i,j,k] = True if
+ point(i,j,k) is in the obstacle.
+
+ Note FP : there are two ways to 'save' which points are
+ in the obstacle : either we set a test function and
+ fill a boolean numpy array (case A) or we compute domain.dimension
+ lists of indice (B).
+ - case A : indices[topo] is a numpy array of the same
+ size as topo.mesh.
+ +++ : very fast to compute, very fast to apply
+ --- : needs more memory (size of bool * topo.mesh.size)
+ - case B : indices[topo] is a tupple of lists, like (ix, iy, iz).
+ A point inside the obstacle is thus given
+ by the indices ix[i], iy[i], iz[i]
+ +++ : needs less memory
+ --- : very slow to compute/apply compared to case A
+ Default choice = case A
+ \todo : provide a way for user to choose between case A and B.
+ Note FP 2: maybe that would be better to save indices in
+ operator (penalization) and not in obstacle, to save memory?
+ """
+ # first check if we have already compute indices for
+ # this topology
+ if topo not in self.ind[0].keys():
+ # for each indicator function
+ self.ind[topo] = []
+ for func in self.chi:
+ # current function position
+ i = self.chi.index(func)
+ # apply indicator function on local mesh for the required topo
+ self.ind[topo].append(self.chi[i](*topo.mesh.coords) <= 0)
+
+ return self.ind[topo]
+
+ def _isempty(self, topo):
+ ilist = np.where(self.ind[topo])
+ if ilist[0].size == 0:
+ self.isEmpty[topo] = True
+ else:
+ self.isEmpty[topo] = False
+
diff --git a/HySoP/hysop/domain/obstacle/planes.py b/HySoP/hysop/domain/obstacle/planes.py
new file mode 100644
index 0000000000000000000000000000000000000000..9d86e45538cc16d0053cd8888574e4a4d06d5d3e
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/planes.py
@@ -0,0 +1,359 @@
+"""
+@file planes.py
+Plate-like sub-domains at boundaries, normal
+to a given direction.
+"""
+from parmepy.domain.obstacle.obstacle import Obstacle
+import numpy as np
+import parmepy.tools.numpywrappers as npw
+
+
+class HalfSpace(Obstacle):
+ """
+ Divide domain into two sub-spaces, on each side of a plane
+ defined by its normal and a point.
+ Indices of this.ind describe the half-space below the plane,
+ 'normal' being the outward normal of the plane.
+ """
+
+ def __init__(self, normal, point, epsilon=1e-2, **kwds):
+ """
+ Half space define by the points of the domain on one side
+ of a plane.
+ @param domain : the physical domain that contains the plane
+ @param normal : outward normal
+ @param point : coordinates of a point of the plane.
+ @param epsilon : tolerance
+ """
+ super(HalfSpace, self).__init__(**kwds)
+ assert epsilon > 0.0, 'Tolerance value must be positive'
+ ## Tolerance used to considered that points at the boundary are
+ ## in the subspace. Good choice may be grid space_step / 2.
+ self.epsilon = epsilon
+ ## Direction of the normal to the plate (0:x, 1:y, 2:z))
+ ## normal is the 'outer' normal of the 'in' subspace.
+ self.normal = npw.integerarray(normal)
+ self.point = point
+ self.origin = npw.realarray(point)
+
+ def Outside(*coords):
+ return sum([(coords[i] - self.point[i]) * self.normal[i]
+ for i in xrange(self.domain.dimension)])
+
+ ## Test function for half-space.
+ ## Positive value if outside subdomain else negative
+ self.chi = [Outside]
+ self.slices = {}
+ ## Global resolution of the obstacle (plane, sub space ...)
+ ## At the time, it's computed only for subspaces, by calling
+ ## globalResolution method.
+ self.gRes = None
+ ## Global index in the original topology of the 'lowest' point
+ ## of the obstacle. Only for subspaces.
+ self.gstart = None
+
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+
+ if topo not in self.ind.keys():
+ self.ind[topo] = []
+ # apply indicator function on topo local mesh
+ cond = npw.asarray(self.chi[0](*topo.mesh.coords) <= self.epsilon)
+ self.ind[topo].append(cond)
+ self._isempty(topo)
+ return self.ind[topo]
+
+ def __str__(self):
+ s = 'Plane normal to vector' + str(self.normal)
+ s += ' going through point ' + str(self.point)
+ return s
+
+
+class Plane(HalfSpace):
+ """
+ A plane in the domain, defined by its normal and a point.
+ Indices of plane.ind describe the points belonging to the plane.
+ """
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+
+ if topo not in self.ind.keys():
+ self.ind[topo] = []
+ # apply indicator function on topo local mesh
+ cond = npw.abs(self.chi[0](*topo.mesh.coords)) < self.epsilon
+ self.ind[topo].append(cond)
+ self._isempty(topo)
+
+ # assert that the plane is a real surface, i.e.
+ # only one value for coords[normalDir].
+ # The expr is a bit tricky but it works ...
+ ndir = np.where(self.normal != 0)[0][0]
+ assert assertSubPlane(ndir, self.ind[topo][0], *topo.mesh.coords),\
+ 'Your plane is not a surface but a volume.\
+ Please reduce epsilon value.'
+
+ return self.ind[topo]
+
+
+class SubSpace(HalfSpace):
+ """
+ Define a rectangular space in a plane normal to one
+ coord. axis and the subspace below this suface.
+ 'Below' = direction opposite to the outward normal of the plane
+ (input param)
+ """
+ def __init__(self, lengths, **kwds):
+ """
+ @param domain : the physical domain that contains the space
+ @param normal : outward normal
+ @param point : coordinates of a point of the plane.
+ @param lengths : lengths of the subplane
+ @param epsilon : tolerance
+ @param vd : velocity of the obstacle (considered as a rigid body),
+ default = 0.
+ """
+ super(SubSpace, self).__init__(**kwds)
+
+ def dist(cdir, val, *coords):
+ return coords[cdir] - val
+
+ self.dist = dist
+ self.max = self.origin + npw.realarray(lengths)
+ self.lengths = npw.realarray(lengths)
+ ndir = np.where(self.normal != 0)[0][0]
+ if self.normal[ndir] > 0:
+ self.max[ndir] = self.origin[ndir]
+ elif self.normal[ndir] < 0:
+ self.max[ndir] = self.domain.max[ndir]
+ # Only implemented for planes orthogonal to coord. axes
+ assert len(self.normal[self.normal == 0]) == self.domain.dimension - 1
+ self.coords = {}
+
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+ condMax = [0] * self.domain.dimension
+ condMin = [0] * self.domain.dimension
+ if topo not in self.ind.keys():
+ self.ind[topo] = []
+ # apply indicator function on topo local mesh
+ coords = topo.mesh.coords
+ cond = npw.asarray(self.chi[0](*coords) < self.epsilon)
+ indices = np.where(self.normal == 0)[0]
+
+ for i in indices:
+ condMax[i] = self.dist(i, self.max[i], *coords) < self.epsilon
+ condMin[i] = self.dist(i, self.origin[i], *coords) > - self.epsilon
+ condMin[i] = np.logical_and(condMax[i], condMin[i])
+ cond = npw.asarray(np.logical_and(cond, condMin[i]))
+
+ self.ind[topo].append(cond)
+ self._isempty(topo)
+ return self.ind[topo]
+
+
+class SubPlane(SubSpace):
+ """
+ Define a rectangular surf in a plane normal to one
+ coord. axis.
+ """
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+ dim = self.domain.dimension
+ condMax = [0] * dim
+ condMin = [0] * dim
+ if topo not in self.ind.keys():
+ self.ind[topo] = []
+ # apply indicator function on topo local mesh
+ coords = topo.mesh.coords
+ cond = npw.abs(self.chi[0](*coords)) < self.epsilon
+ indices = np.where(self.normal == 0)[0]
+ for i in indices:
+ condMax[i] = self.dist(i, self.max[i], *coords) < self.epsilon
+ condMin[i] = self.dist(i, self.origin[i], *coords) > -self.epsilon
+ condMin[i] = np.logical_and(condMax[i], condMin[i])
+ cond = npw.asarray(np.logical_and(cond, condMin[i]))
+
+ self.ind[topo].append(cond)
+ ilist = np.where(cond)
+ if ilist[0].size == 0:
+ self.slices[topo] = [slice(0, 0) for i in xrange(dim)]
+ self.isEmpty[topo] = True
+ else:
+ self.isEmpty[topo] = False
+ start = [ilist[i].min() for i in xrange(dim)]
+ # Ghost points must not be included into surf. points
+ ic = topo.mesh.iCompute
+ start = [max(start[i], ic[i].start) for i in xrange(dim)]
+ end = [ilist[i].max() for i in xrange(dim)]
+ end = npw.integerarray([min(end[i], ic[i].stop - 1)
+ for i in xrange(dim)])
+ end += 1
+ ndir = np.where(self.normal != 0)[0][0]
+ end[ndir] = start[ndir] + 1
+ self.slices[topo] = [slice(start[i], end[i])
+ for i in xrange(dim)]
+ assert assertSubPlane(ndir, cond, *topo.mesh.coords),\
+ 'Your plane is not a surface but a volume.\
+ Please reduce epsilon value.'
+ subcoords = []
+ # !! Warning : slices will be used for integration,
+ # so the last point in each dir is not included.
+ # Same thing for coords.
+ for i in xrange(dim):
+ subcoords.append(coords[i].flat[self.slices[topo][i]])
+ subcoords = tuple(subcoords)
+ self.coords[topo] = np.ix_(*subcoords)
+ return self.ind[topo]
+
+ def globalResolution(self, parent_topo):
+ """
+ Compute 'global resolution' of the subplane
+ """
+ # We create a false topology, with only one proc
+ # to get the global resolution for the plane.
+ # This could also be done with local computation
+ # sum but that would need a lot of communications.
+ if parent_topo.rank == 0:
+ color = 0
+ else:
+ color = 1
+ subcomm = parent_topo.comm.Split(color)
+ dimension = self.domain.dimension
+ tmp = None
+ if parent_topo.rank == 0:
+ resolution = parent_topo.globalMeshResolution
+ ghosts = parent_topo.ghosts
+ topo = self.domain.getOrCreateTopology(3, resolution,
+ ghosts=ghosts, comm=subcomm)
+ self.discretize(topo)
+ sl = self.slices[topo]
+ self.gRes = [sl[i].stop - sl[i].start for i in xrange(dimension)]
+ self.gstart = [sl[i].start for i in xrange(dimension)]
+ # if the topology has been created just to
+ # get the global resolution, we can remove it
+ if topo.isNew:
+ self.domain.remove(topo)
+ self.slices.pop(topo)
+ self.ind.pop(topo)
+ tmp = self.gRes + self.gstart
+ tmp = parent_topo.comm.bcast(tmp)
+ self.gRes = tmp[:dimension]
+ self.gstart = tmp[dimension:]
+ return self.gRes
+
+
+class PlaneBoundaries(Obstacle):
+ """
+ Defines top and down (meaning for min and max value in
+ a given direction) planes at boundaries.
+ All points in the spaces above the top plane and below the down plane
+ will be included in the PlaneBoundaries list of indices.
+ Thickness of the top/down areas is given as an input param.
+ Example for z dir:
+ \f$ \{x,y,z\} \ for \ z_{max} - \epsilon \leq z \leq z_{max} + \epsilon
+ \ or \ z_{min} - \epsilon \leq z \leq z_{min}\f$
+ """
+
+ def __init__(self, normal_dir, thickness=0.1, **kwds):
+ """
+ Description of a sphere in a domain.
+ @param domain : the physical domain that contains the sphere.
+ @param thickness : thickness of boundary areas
+ @param vd : velocity of obstacle (considered as a rigid body),
+ default = 0.
+ """
+ super(PlaneBoundaries, self).__init__(**kwds)
+ assert thickness > 0.0, 'Plate thickness must be positive'
+ ## Thickness/2
+ self.thickness = thickness
+ ## Direction of the normal to the plate (0:x, 1:y, 2:z))
+ normalUp = np.zeros((self.domain.dimension))
+ normalUp[normal_dir] = -1
+ pointUp = npw.zeros((self.domain.dimension))
+ pointUp[normal_dir] = self.domain.max[normal_dir] - thickness
+ self.upper = HalfSpace(domain=self.domain, normal=normalUp, point=pointUp,
+ epsilon=1e-3)
+ normalDown = np.zeros((self.domain.dimension))
+ normalDown[normal_dir] = 1
+ pointDown = npw.zeros((self.domain.dimension))
+ pointDown[normal_dir] = self.domain.origin[normal_dir] + thickness
+ self.lower = HalfSpace(domain=self.domain, normal=normalDown,
+ point=pointDown, epsilon=1e-3)
+
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+
+ self.lower.discretize(topo)
+ self.upper.discretize(topo)
+ if topo not in self.ind.keys():
+ # Warning FP : ind[topo] must be a list to be coherent
+ # with sphere definition, where porous layers are allowed.
+ # todo if required : add porous layers for planes.
+ self.ind[topo] = []
+ self.ind[topo].append(np.logical_or(self.upper.ind[topo][0],
+ self.lower.ind[topo][0]))
+ self._isempty(topo)
+ return self.ind[topo]
+
+
+def assertSubPlane(ndir, ind, *coords):
+ dim = len(coords)
+ if dim == 2:
+ return assertline(ndir, ind, *coords)
+ elif dim == 3:
+ return assertsurface(ndir, ind, *coords)
+
+
+def assertsurface(nd, ind, *coords):
+
+ dim = len(coords)
+ shape = np.zeros(dim, dtype=np.int32)
+ shape[:] = [coords[i].shape[i] for i in xrange(dim)]
+ cshape = coords[nd].shape
+ if nd == 0:
+ return max([a.max() - a.min()
+ for a in [coords[nd][ind[:, i, j]]
+ for i in xrange(shape[1])
+ for j in xrange(shape[2])
+ if coords[nd][ind[:, i, j]].size
+ > 0]] + [0]) == 0.
+ elif nd == 1:
+ return max([a.max() - a.min()
+ for a in [coords[nd][ind[i, :, j].reshape(cshape)]
+ for i in xrange(shape[0])
+ for j in xrange(shape[2])
+ if coords[nd][ind[i, :, j].reshape(cshape)].size
+ > 0]] + [0]) == 0.
+
+ else:
+ return max([a.max() - a.min()
+ for a in [coords[nd][ind[i, j, :].reshape(cshape)]
+ for i in xrange(shape[0])
+ for j in xrange(shape[1])
+ if coords[nd][ind[i, j, :].reshape(cshape)].size
+ > 0]] + [0]) == 0.
+
+
+def assertline(nd, ind, *coords):
+
+ dim = len(coords)
+ shape = np.zeros(dim, dtype=np.int32)
+ shape[:] = [coords[i].shape[i] for i in xrange(dim)]
+ cshape = coords[nd].shape
+ if nd == 0:
+ return max([a.max() - a.min()
+ for a in [coords[nd][ind[:, i]]
+ for i in xrange(shape[1])
+ if coords[nd][ind[:, i]].size
+ > 0]] + [0]) == 0.
+ elif nd == 1:
+ return max([a.max() - a.min()
+ for a in [coords[nd][ind[i, :].reshape(cshape)]
+ for i in xrange(shape[0])
+ if coords[nd][ind[i, :].reshape(cshape)].size
+ > 0]] + [0]) == 0.
diff --git a/HySoP/hysop/domain/obstacle/sphere.py b/HySoP/hysop/domain/obstacle/sphere.py
new file mode 100644
index 0000000000000000000000000000000000000000..1bb0d62c7f6ad0b9d8cb19803f1629a31e9f8702
--- /dev/null
+++ b/HySoP/hysop/domain/obstacle/sphere.py
@@ -0,0 +1,132 @@
+"""
+@file sphere.py
+Spherical or hemispherical sub-domain.
+"""
+from parmepy.domain.obstacle.obstacle import Obstacle
+import numpy as np
+import parmepy.tools.numpywrappers as npw
+
+
+class Sphere(Obstacle):
+ """
+ Spherical domain.
+ """
+
+ def __init__(self, position, radius=1.0, porousLayers=None, **kwds):
+ """
+ Description of a sphere in a domain.
+ @param domain : the physical domain that contains the sphere.
+ @param position : position of the center
+ @param radius : sphere radius, default = 1
+ @param porousLayers : a list of thicknesses
+ for successive porous layers
+ radius is the inside sphere radius and thicknesses are given from
+ inside layer to outside one.
+ @param vd : velocity of the sphere (considered as a rigid body),
+ default = 0.
+ """
+ super(Sphere, self).__init__(**kwds)
+
+ ## Radius of the sphere
+ self.radius = radius
+ ## Center position
+ self.position = np.asarray(position)
+
+ def dist(x, y, z, R):
+ """
+ """
+ return npw.asarray(np.sqrt((x - self.position[0]) ** 2
+ + (y - self.position[1]) ** 2
+ + (z - self.position[2]) ** 2) - R)
+
+ self.chi = [dist]
+ ## List of thicknesses for porous layers
+ if porousLayers is None:
+ porousLayers = []
+ self.layers = porousLayers
+
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+
+ if topo not in self.ind.keys():
+ currentRadius = self.radius
+ self.ind[topo] = []
+ # First, internal sphere
+ args = (currentRadius,)
+ self.ind[topo].append(self.chi[0](*(topo.mesh.coords + args)) <= 0)
+ # Then each layer from inside to outside
+ # for each indicator function
+ for thickness in self.layers:
+ # apply indicator function on topo local mesh
+ args = (currentRadius,)
+ condA = self.chi[0](*(topo.mesh.coords + args)) > 0
+ args = (currentRadius + thickness,)
+ condB = self.chi[0](*(topo.mesh.coords + args)) <= 0
+ self.ind[topo].append(np.logical_and(condA, condB))
+ # update current radius
+ currentRadius = currentRadius + thickness
+ self._isempty(topo)
+ return self.ind[topo]
+
+ def __str__(self):
+ """ToString method"""
+ s = self.__class__.__name__ + ' of radius ' + str(self.radius)
+ s += ' and center position ' + str(self.position)
+ return s
+
+
+class HemiSphere(Sphere):
+ """
+ HemiSpherical domain.
+ Area defined by the intersection of a sphere and the volume where
+ x < xs for xs == x position of the center of the sphere.
+ """
+ def __init__(self, **kwds):
+ """
+ Description of a sphere in a domain.
+ @param domain : the physical domain that contains the sphere.
+ @param position : position of the center
+ @param radius : sphere radius, default = 1
+ @param porousLayers : a list of thicknesses
+ for successive porous layers
+ radius is the inside sphere radius and thicknesses are given from
+ inside layer to outside one.
+ @param vd : velocity of the sphere (considered as a rigid body),
+ default = 0.
+ """
+ super(HemiSphere, self).__init__(**kwds)
+
+ def LeftBox(x, y, z):
+ return x - self.position[0]
+ self.LeftBox = LeftBox
+
+ def discretize(self, topo):
+ # first check if we have already compute indices for
+ # this topology
+ if topo not in self.ind.keys():
+ currentRadius = self.radius
+ self.ind[topo] = []
+ # check if we are in the left half-box
+ cond0 = self.LeftBox(*(topo.mesh.coords)) <= 0
+ # First, internal sphere
+ args = (currentRadius,)
+ condA = self.chi[0](*(topo.mesh.coords + args)) <= 0
+ self.ind[topo].append(np.logical_and(condA, cond0))
+ # Then each layer from inside to outside
+ # for each indicator function
+ for thickness in self.layers:
+ # apply indicator function on topo local mesh
+ args = (currentRadius,)
+ condA = self.chi[0](*(topo.mesh.coords + args)) > 0
+ args = (currentRadius + thickness,)
+ condB = self.chi[0](*(topo.mesh.coords + args)) <= 0
+ np.logical_and(condA, condB, condA)
+ np.logical_and(condA, cond0, condA)
+ condA = npw.asarray(condA)
+ self.ind[topo].append(condA)
+ # update current radius
+ currentRadius = currentRadius + thickness
+ self._isempty(topo)
+
+ return self.ind[topo]
diff --git a/HySoP/hysop/domain/tests/test_obstacle.py b/HySoP/hysop/domain/tests/test_obstacle.py
new file mode 100644
index 0000000000000000000000000000000000000000..75b274f7435963085b6e1f7bbe7c80225b48e9e7
--- /dev/null
+++ b/HySoP/hysop/domain/tests/test_obstacle.py
@@ -0,0 +1,267 @@
+"""
+Testing parmepy.domain.obstacle.Obstacle
+"""
+import parmepy as pp
+from parmepy.fields.continuous import Field
+from parmepy.mpi.topology import Cartesian
+from parmepy.domain.obstacle.sphere import Sphere, HemiSphere
+from parmepy.domain.obstacle.disk import Disk, HalfDisk
+from parmepy.domain.obstacle.planes import HalfSpace, Plane, SubSpace,\
+ SubPlane, PlaneBoundaries
+from parmepy.domain.obstacle.controlBox import ControlBox
+import numpy as np
+from parmepy.constants import CHECK_F_CONT
+
+
+nb = 129
+Lx = Ly = Lz = 2
+dom = pp.Box(dimension=3, length=[Lx, Ly, Lz], origin=[-1., -1., -1.])
+dom2D = pp.Box(dimension=2, length=[Lx, Ly], origin=[-1., -1.])
+resol3D = [nb, nb, nb]
+resol2D = [nb, nb]
+scal = Field(domain=dom)
+scal2D = Field(domain=dom2D)
+topo = Cartesian(dom, 3, resol3D)
+topo2D = Cartesian(dom2D, 2, resol2D)
+coords = topo.mesh.coords
+coords2D = topo2D.mesh.coords
+scald = scal.discretize(topo).data[0]
+scald2D = scal2D.discretize(topo2D).data[0]
+h3d = topo.mesh.space_step
+h2d = topo2D.mesh.space_step
+dvol = np.prod(h3d)
+ds = np.prod(h2d)
+import math
+pi = math.pi
+tol = 1e-6
+lengths = np.asarray([20 * h3d[0], 22 * h3d[1], 31 * h3d[2]])
+rlengths = lengths + h3d
+rlengths2d = lengths[:2] + h2d
+scald[:] = 1.
+scald2D[:] = 1.
+
+
+def testSphere():
+ scald[:] = 1.
+ rad = 0.3
+ sphere = Sphere(domain=dom, position=[0., 0., 0.],
+ radius=rad, porousLayers=[0.13])
+
+ sphere.discretize(topo)
+ ind = sphere.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([-0.2, 0, 0.2])
+ assert ind[ix, iy, iz]
+ (ix, iy, iz) = topo.mesh.indices([0.5, 0.1, 0.2])
+ assert not ind[ix, iy, iz]
+
+
+def testHemiSphere():
+ scald[:] = 1.
+ rad = 0.3
+ sphere = HemiSphere(domain=dom, position=[0., 0., 0.],
+ radius=rad, porousLayers=[0.13])
+
+ sphere.discretize(topo)
+ ind = sphere.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([-0.3, 0., 0.])
+ assert ind[ix, iy, iz]
+ (ix, iy, iz) = topo.mesh.indices([0.3, 0., 0.])
+ assert not ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testDisk():
+ scald2D[:] = 1.
+ rad = 0.3
+ sphere = Disk(domain=dom2D, position=[0., 0.],
+ radius=rad, porousLayers=[0.13])
+
+ sphere.discretize(topo2D)
+ ind = sphere.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.2, 0.])
+ assert ind[ix, iy]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testHalfDisk():
+ scald2D[:] = 1.
+ rad = 0.3
+ sphere = HalfDisk(domain=dom2D, position=[0., 0.],
+ radius=rad, porousLayers=[0.13])
+
+ sphere.discretize(topo2D)
+ ind = sphere.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.2, 0.])
+ assert ind[ix, iy]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testHalfSpace2D():
+ hsp = HalfSpace(domain=dom2D, normal=[1, 1], point=[0., 0.])
+ hsp.discretize(topo2D)
+ ind = hsp.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.8, 0.5])
+ assert ind[ix, iy]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testHalfSpace3D():
+ hsp = HalfSpace(domain=dom, normal=[1, 1, 1], point=[0., 0., 0.])
+ hsp.discretize(topo)
+ ind = hsp.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([-0.8, 0.5, -0.5])
+ assert ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testPlane2D():
+ plane = Plane(domain=dom2D, normal=[1, 1], point=[0., 0.])
+ plane.discretize(topo2D)
+ ind = plane.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.5, 0.5])
+ assert ind[ix, iy]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testPlane3D():
+ plane = Plane(domain=dom, normal=[1, 1, 1], point=[0., 0., 0.])
+ plane.discretize(topo)
+ ind = plane.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([-0.3, 0.5, -0.2])
+ assert ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testSubSpace2D():
+ ssp = SubSpace(domain=dom2D, normal=[1, 0.], point=[0., 0.], lengths=lengths[:2])
+ ssp.discretize(topo2D)
+ ind = ssp.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.5, 0.2])
+ assert ind[ix, iy]
+
+
+def testSubSpace3D():
+ ssp = SubSpace(domain=dom, normal=[0, 1, 0], point=[0., 0., 0.], lengths=lengths)
+ ssp.discretize(topo)
+ ind = ssp.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([0.3, -0.1, 0.2])
+ assert ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testSubPlane2D():
+ ssp = SubPlane(domain=dom2D, normal=[1, 0], point=[0., 0.], lengths=lengths[:2])
+ ssp.discretize(topo2D)
+ ind = ssp.ind[topo2D][0]
+ ll = np.sum(scald2D[ind]) * h2d[1]
+ rll = rlengths2d[1]
+ assert abs(ll - rll) < tol
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testSubPlane3D():
+ ssp = SubPlane(domain=dom, normal=[0, 1, 0], point=[0., 0., 0.], lengths=lengths)
+ ssp.discretize(topo)
+ ind = ssp.ind[topo][0]
+ surf = np.sum(scald[ind]) * ds
+ rsurf = rlengths[0] * rlengths[2]
+ assert abs(surf - rsurf) < tol
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testPlaneBC2D():
+ bc = PlaneBoundaries(domain=dom2D, normal_dir=1, thickness=0.2)
+ bc.discretize(topo2D)
+ ind = bc.ind[topo2D][0]
+ (ix, iy) = topo2D.mesh.indices([-0.5, - Ly * 0.5])
+ assert ind[ix, iy]
+ (ix, iy) = topo2D.mesh.indices([-0.5, Ly * 0.5 - 2 * h2d[1]])
+ assert ind[ix, iy]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testPlaneBC3D():
+ bc = PlaneBoundaries(domain=dom, normal_dir=1, thickness=0.2)
+ bc.discretize(topo)
+ ind = bc.ind[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([-0.5, -Ly * 0.5, 0.3])
+ assert ind[ix, iy, iz]
+ (ix, iy, iz) = topo.mesh.indices([-0.5, Ly * 0.5 - 2 * h2d[1], 0.3])
+ assert ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+
+def testControlBox2D():
+ lx = 10 * h3d[0]
+ ly = 22 * h3d[1]
+
+ cb = ControlBox(domain=dom2D, origin=[-0.5, -0.5], lengths=[lx, ly])
+ cb.discretize(topo2D)
+ surf = cb.integrate(scal2D, topo2D)
+ rsurf = lx * ly
+ assert abs(surf - rsurf) < tol
+ assert cb.ind[topo2D][0].flags.f_contiguous is CHECK_F_CONT
+
+
+def testControlBox3D():
+ ll = np.asarray([0] * 3)
+ ll[0] = 10 * h3d[0]
+ ll[1] = 22 * h3d[1]
+ ll[2] = 51 * h3d[2]
+
+ cb = ControlBox(domain=dom, origin=[0.5, -0.5, -0.5], lengths=ll)
+ cb.discretize(topo)
+ vol = cb.integrate(scal, topo)
+ rvol = np.prod(ll)
+ assert abs(rvol - vol) < tol
+
+ vol = cb.integrate(scal, topo, useSlice=False)
+ assert abs(rvol - vol) < tol
+ ind = np.asarray([0, 1, 2])
+ for i in xrange(3):
+ surfUp = cb.integrateOnSurface(scal, topo, normalDir=i, up=True)
+ surfDown = cb.integrateOnSurface(scal, topo, normalDir=i, up=False)
+ j = np.where(ind != i)
+ sref = np.prod(ll[j])
+ assert abs(surfUp - sref) < tol
+ assert abs(surfDown - sref) < tol
+
+ assert cb.ind[topo][0].flags.f_contiguous is CHECK_F_CONT
+
+
+def testControlBoxSphere():
+ lx = 1.5
+ ly = 1.5
+ lz = 1.5
+ rad = 0.2
+ cb = ControlBox(domain=dom, origin=[-0.75, -0.75, -0.75], lengths=[lx, ly, lz])
+ layer = 2 * h3d[0]
+ sphere = Sphere(domain=dom, position=[0., 0., 0.],
+ radius=rad, porousLayers=[layer])
+ cb.sub(sphere, topo)
+ ind = cb.indReduced[topo][0]
+ (ix, iy, iz) = topo.mesh.indices([0.1, 0.0, 0.])
+ assert not ind[ix, iy, iz]
+ (ix, iy, iz) = topo.mesh.indices([0.3, 0.0, 0.])
+ assert ind[ix, iy, iz]
+ assert ind.flags.f_contiguous is CHECK_F_CONT
+
+# This may be useful to run mpi tests
+#if __name__ == "__main__":
+ ## TODO : add tests for distributed obstacles.
+ ## testHemiSphere()
+ ## testDisk()
+ ## testHalfDisk()
+ ## testHalfSpace2D()
+ ## testHalfSpace3D()
+ ## testPlane2D()
+ ## testPlane3D()
+ ## testSubSpace2D()
+ ## testSubSpace3D()
+ ## testSubPlane2D()
+ ## testSubPlane3D()
+ ## testPlaneBC2D()
+ ## testPlaneBC3D()
+ ## testControlBox2D()
+ ## testControlBox3D()
+ ## testControlBoxSphere()
diff --git a/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_2d.cl b/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_2d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..10a605498143598c3ee501bc516c30ea419514a7
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_2d.cl
@@ -0,0 +1,83 @@
+/**
+ * @file advection_and_remeshing_vector_2d.cl
+ * Advection and remeshing kernel for 2D vector advection.
+ */
+
+/**
+ * Performs advection and then remeshing of the particles' vector.
+ * A work-group is handling a 1D problem. Thus, gidY and gidZ are constants among work-items of a work-group.
+ * Each work-item computes NB_I/WI_NB particles positions. To avoid concurrent witings, in case of strong velocity gradients, work-items computes contiguous particles.
+ * Particle are computed through OpenCL vector types of lenght 2, 4 or 8.
+ * Scalar results are stored in a local buffer as a cache and then copied to global memory buffer.
+ *
+ * @param gvelo Velocity field
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param dt Time step
+ * @param min_position Domain lower coordinate
+ * @param dx Space step
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>WI_NB</code> corresponds to the work-item number.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @see parmepy.gpu.tools.parse_file
+ */
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pvec_X,
+ __global const float* pvec_Y,
+ __global float* gvec_X,
+ __global float* gvec_Y,
+ float dt,float min_position, float dx)
+{
+ uint gidX = get_global_id(0); /* OpenCL work-itme global index (X) */
+ uint gidY = get_global_id(1); /* OpenCL work-itme global index (Y) */
+ uint gidZ = get_global_id(2); /* OpenCL work-itme global index (Z) */
+ float invdx = 1.0/dx; /* Space step inverse */
+ uint i; /* Particle index in 1D problem */
+ float__N__ p, /* Particle position */
+ pv_X, pv_Y, /* Particle vector */
+ v; /* Particle velocity */
+ uint line_index = gidY*NB_I+ gidZ*NB_I*NB_II; /* Current 1D problem index */
+
+ __local float gvec_X_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Y_loc[NB_I]; /* Local buffer for result */
+ __local float gvelo_loc[NB_I]; /* Velocity cache */
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Read velocity */
+ v = vload__N__((i+line_index)/__N__, gvelo);
+ /* Fill velocity cache */
+ gvelo_loc[noBC_id(i+__NN__)] = v.s__NN__;
+ /* Initialize result buffer */
+ gvec_X_loc[noBC_id(i+__NN__)] = 0.0;
+ gvec_Y_loc[noBC_id(i+__NN__)] = 0.0;
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*PART_NB_PER_WI; i<(gidX + 1)*PART_NB_PER_WI; i+=__N__)
+ {
+ /* Read Particle scalar */
+ pv_X = vload__N__((i + line_index)/__N__, pvec_X);
+ pv_Y = vload__N__((i + line_index)/__N__, pvec_Y);
+ /* Compute particle position */
+ p = advection(i, dt, dx, invdx, gvelo_loc);
+ /* Remesh particle */
+ remesh(i, dx, invdx, pv_X, pv_Y, p, gvec_X_loc, gvec_Y_loc);
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Store result */
+ vstore__N__((float__N__)(gvec_X_loc[noBC_id(i+__NN__)],
+ ), (i + line_index)/__N__, gvec_X);
+ vstore__N__((float__N__)(gvec_Y_loc[noBC_id(i+__NN__)],
+ ), (i + line_index)/__N__, gvec_Y);
+ }
+}
diff --git a/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_3d.cl b/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_3d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..abbdbe006a226f4fcbcd01d97b33201653c54a36
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/kernels/advection_and_remeshing_vector_3d.cl
@@ -0,0 +1,90 @@
+/**
+ * @file advection_and_remeshing_vector_3d.cl
+ * Advection and remeshing kernel for 3D vector advection.
+ */
+
+/**
+ * Performs advection and then remeshing of the particles' vector.
+ * A work-group is handling a 1D problem. Thus, gidY and gidZ are constants among work-items of a work-group.
+ * Each work-item computes NB_I/WI_NB particles positions. To avoid concurrent witings, in case of strong velocity gradients, work-items computes contiguous particles.
+ * Particle are computed through OpenCL vector types of lenght 2, 4 or 8.
+ * Scalar results are stored in a local buffer as a cache and then copied to global memory buffer.
+ *
+ * @param gvelo Velocity field
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param dt Time step
+ * @param min_position Domain lower coordinate
+ * @param dx Space step
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>WI_NB</code> corresponds to the work-item number.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @see parmepy.gpu.tools.parse_file
+ */
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pvec_X,
+ __global const float* pvec_Y,
+ __global const float* pvec_Z,
+ __global float* gvec_X,
+ __global float* gvec_Y,
+ __global float* gvec_Z,
+ float dt,float min_position, float dx)
+{
+ uint gidX = get_global_id(0); /* OpenCL work-itme global index (X) */
+ uint gidY = get_global_id(1); /* OpenCL work-itme global index (Y) */
+ uint gidZ = get_global_id(2); /* OpenCL work-itme global index (Z) */
+ float invdx = 1.0/dx; /* Space step inverse */
+ uint i; /* Particle index in 1D problem */
+ float__N__ p, /* Particle position */
+ pv_X, pv_Y, pv_Z, /* Particle vector */
+ v; /* Particle velocity */
+ uint line_index = gidY*NB_I+ gidZ*NB_I*NB_II; /* Current 1D problem index */
+
+ __local float gvec_X_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Y_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Z_loc[NB_I]; /* Local buffer for result */
+ __local float gvelo_loc[NB_I]; /* Velocity cache */
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Read velocity */
+ v = vload__N__((i+line_index)/__N__, gvelo);
+ /* Fill velocity cache */
+ gvelo_loc[noBC_id(i+__NN__)] = v.s__NN__;
+ /* Initialize result buffer */
+ gvec_X_loc[noBC_id(i+__NN__)] = 0.0;
+ gvec_Y_loc[noBC_id(i+__NN__)] = 0.0;
+ gvec_Z_loc[noBC_id(i+__NN__)] = 0.0;
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*PART_NB_PER_WI; i<(gidX + 1)*PART_NB_PER_WI; i+=__N__)
+ {
+ /* Read Particle scalar */
+ pv_X = vload__N__((i + line_index)/__N__, pvec_X);
+ pv_Y = vload__N__((i + line_index)/__N__, pvec_Y);
+ pv_Z = vload__N__((i + line_index)/__N__, pvec_Z);
+ /* Compute particle position */
+ p = advection(i, dt, dx, invdx, gvelo_loc);
+ /* Remesh particle */
+ remesh(i, dx, invdx, pv_X, pv_Y, pv_Z, p, gvec_X_loc, gvec_Y_loc, gvec_Z_loc);
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Store result */
+ vstore__N__((float__N__)(gvec_X_loc[noBC_id(i+__NN__)],
+ ), (i + line_index)/__N__, gvec_X);
+ vstore__N__((float__N__)(gvec_Y_loc[noBC_id(i+__NN__)],
+ ), (i + line_index)/__N__, gvec_Y);
+ vstore__N__((float__N__)(gvec_Z_loc[noBC_id(i+__NN__)],
+ ), (i + line_index)/__N__, gvec_Z);
+ }
+}
diff --git a/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_2d.cl b/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_2d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..84cb5d3605ee633f4eb51124c2fd9f88e44a62d3
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_2d.cl
@@ -0,0 +1,76 @@
+/**
+ * @file remeshing_vector_2d.cl
+ * Remeshing kernel.
+ */
+
+/**
+ * Performs remeshing of the particles' vector in 2d.
+ * A work-group is handling a 1D problem. Thus, gidY and gidZ are constants among work-items of a work-group.
+ * Each work-item computes <code>NB_I/WI_NB</code> particles positions. To avoid concurrent witings, in case of strong velocity gradients, work-items computes contiguous particles.
+ * Particle are computed through OpenCL vector types of lenght 2, 4 or 8.
+ * Scalar results are stored in a local buffer as a cache and then copied to global memory buffer.
+ *
+ * @param ppos Particle position
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param min_position Domain lower coordinate
+ * @param dx Space step
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>WI_NB</code> corresponds to the work-item number.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @see parmepy.gpu.tools.parse_file
+ */
+__kernel void remeshing_kernel(__global const float* ppos,
+ __global const float* pvec_X,
+ __global const float* pvec_Y,
+ __global float* gvec_X,
+ __global float* gvec_Y,
+ float min_position, float dx)
+{
+ uint gidX = get_global_id(0); /* OpenCL work-itme global index (X) */
+ uint gidY = get_global_id(1); /* OpenCL work-itme global index (Y) */
+ uint gidZ = get_global_id(2); /* OpenCL work-itme global index (Z) */
+ float invdx = 1.0/dx; /* Space step inverse */
+ uint i; /* Particle index in 1D problem */
+ float__N__ p, /* Particle position */
+ v_X, v_Y; /* Particle quantity */
+ uint line_index = gidY*NB_I+ gidZ*NB_I*NB_II; /* Current 1D problem index */
+
+ __local float gvec_X_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Y_loc[NB_I]; /* Local buffer for result */
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Initialize result buffer */
+ gvec_X_loc[i+__NN__] = 0.0;
+ gvec_Y_loc[i+__NN__] = 0.0;
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*PART_NB_PER_WI; i<(gidX + 1)*PART_NB_PER_WI; i+=__N__)
+ {
+ /* Read particle position */
+ p = vload__N__((i + line_index)/__N__, ppos) - (float__N__)(min_position);
+ /* Read particle scalar */
+ v_X = vload__N__((i + line_index)/__N__, pvec_X);
+ v_Y = vload__N__((i + line_index)/__N__, pvec_Y);
+ /* Remesh particle */
+ remesh(i, dx, invdx, v_X, v_Y, p, gvec_X_loc, gvec_Y_loc);
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Store result */
+ vstore__N__((float__N__)(gvec_X_loc[noBC_id(i+__NN__)],
+ ),(i + line_index)/__N__, gvec_X);
+ vstore__N__((float__N__)(gvec_Y_loc[noBC_id(i+__NN__)],
+ ),(i + line_index)/__N__, gvec_Y);
+ }
+}
diff --git a/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_3d.cl b/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_3d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..0f66a22ab3691b2f465c8380d8b0a88c7dd67022
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/kernels/remeshing_vector_3d.cl
@@ -0,0 +1,83 @@
+/**
+ * @file remeshing_vector_3d.cl
+ * Remeshing kernel.
+ */
+
+/**
+ * Performs remeshing of the particles' vector in 3d.
+ * A work-group is handling a 1D problem. Thus, gidY and gidZ are constants among work-items of a work-group.
+ * Each work-item computes <code>NB_I/WI_NB</code> particles positions. To avoid concurrent witings, in case of strong velocity gradients, work-items computes contiguous particles.
+ * Particle are computed through OpenCL vector types of lenght 2, 4 or 8.
+ * Scalar results are stored in a local buffer as a cache and then copied to global memory buffer.
+ *
+ * @param ppos Particle position
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param min_position Domain lower coordinate
+ * @param dx Space step
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>WI_NB</code> corresponds to the work-item number.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @see parmepy.gpu.tools.parse_file
+ */
+__kernel void remeshing_kernel(__global const float* ppos,
+ __global const float* pvec_X,
+ __global const float* pvec_Y,
+ __global const float* pvec_Z,
+ __global float* gvec_X,
+ __global float* gvec_Y,
+ __global float* gvec_Z,
+ float min_position, float dx)
+{
+ uint gidX = get_global_id(0); /* OpenCL work-itme global index (X) */
+ uint gidY = get_global_id(1); /* OpenCL work-itme global index (Y) */
+ uint gidZ = get_global_id(2); /* OpenCL work-itme global index (Z) */
+ float invdx = 1.0/dx; /* Space step inverse */
+ uint i; /* Particle index in 1D problem */
+ float__N__ p, /* Particle position */
+ v_X, v_Y, v_Z; /* Particle quantity */
+ uint line_index = gidY*NB_I+ gidZ*NB_I*NB_II; /* Current 1D problem index */
+
+ __local float gvec_X_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Y_loc[NB_I]; /* Local buffer for result */
+ __local float gvec_Z_loc[NB_I]; /* Local buffer for result */
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Initialize result buffer */
+ gvec_X_loc[i+__NN__] = 0.0;
+ gvec_Y_loc[i+__NN__] = 0.0;
+ gvec_Z_loc[i+__NN__] = 0.0;
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*PART_NB_PER_WI; i<(gidX + 1)*PART_NB_PER_WI; i+=__N__)
+ {
+ /* Read particle position */
+ p = vload__N__((i + line_index)/__N__, ppos) - (float__N__)(min_position);
+ /* Read particle scalar */
+ v_X = vload__N__((i + line_index)/__N__, pvec_X);
+ v_Y = vload__N__((i + line_index)/__N__, pvec_Y);
+ v_Z = vload__N__((i + line_index)/__N__, pvec_Z);
+ /* Remesh particle */
+ remesh(i, dx, invdx, v_X, v_Y, v_Z, p, gvec_X_loc, gvec_Y_loc, gvec_Z_loc);
+ }
+
+ /* Synchronize work-group */
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*__N__; i<NB_I; i+=(WI_NB*__N__))
+ {
+ /* Store result */
+ vstore__N__((float__N__)(gvec_X_loc[noBC_id(i+__NN__)],
+ ),(i + line_index)/__N__, gvec_X);
+ vstore__N__((float__N__)(gvec_Y_loc[noBC_id(i+__NN__)],
+ ),(i + line_index)/__N__, gvec_Y);
+ vstore__N__((float__N__)(gvec_Z_loc[noBC_id(i+__NN__)],
+ ),(i + line_index)/__N__, gvec_Z);
+ }
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_2d.cl b/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_2d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..abb672668533bcc6ba6bd534f3c683b8baf3d230
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_2d.cl
@@ -0,0 +1,111 @@
+/**
+ * @file basic_noVec_vector_2d.cl
+ * Remeshing function, vectorized version for 2D vector remeshing.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float v_X, float v_Y,
+ float p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float v_X, float v_Y,
+ float p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc){
+ float y; /* Normalized distance to nearest left grid point */
+ int ind; /* Integer coordinate */
+ uint index; /* Remeshing index */
+ float w;
+
+ ind = convert_int_rtn(p * invdx);
+ y = (p - convert_float(ind) * dx) * invdx;
+
+ index = convert_uint((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w = REMESH(alpha)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(beta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(gamma)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(delta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w = REMESH(eta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(zeta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w = REMESH(theta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(iota)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w = REMESH(kappa)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(mu)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_3d.cl b/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_3d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..c912769d9fb96fbce7284933bc8a46df117599a7
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/basic_noVec_vector_3d.cl
@@ -0,0 +1,121 @@
+/**
+ * @file basic_noVec_vector_3d.cl
+ * Remeshing function, vectorized version for 3D vector remeshing.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float v_X, float v_Y, float v_Z,
+ float p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float v_X, float v_Y, float v_Z,
+ float p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc){
+ float y; /* Normalized distance to nearest left grid point */
+ int ind; /* Integer coordinate */
+ uint index; /* Remeshing index */
+ float w;
+
+ ind = convert_int_rtn(p * invdx);
+ y = (p - convert_float(ind) * dx) * invdx;
+
+ index = convert_uint((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w = REMESH(alpha)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(beta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(gamma)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(delta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w = REMESH(eta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(zeta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w = REMESH(theta)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(iota)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w = REMESH(kappa)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(mu)(y);
+ gvec_X_loc[noBC_id(index)] += (w * v_X);
+ gvec_Y_loc[noBC_id(index)] += (w * v_Y);
+ gvec_Z_loc[noBC_id(index)] += (w * v_Z);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_2d.cl b/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_2d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..da8d9234bea16158cf5d215410ca0cec2cbc3fe1
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_2d.cl
@@ -0,0 +1,111 @@
+/**
+ * @file basic_vector_2d.cl
+ * Remeshing function, vectorized version for vector remeshing in 2D.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc){
+ float__N__ y; /* Normalized distance to nearest left grid point */
+ int__N__ ind; /* Integer coordinate */
+ uint__N__ index; /* Remeshing index */
+ float w__NN__;
+
+ ind = convert_int__N___rtn(p * invdx);
+ y = (p - convert_float__N__(ind) * dx) * invdx;
+
+ index = convert_uint__N__((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w__NN__ = REMESH(alpha)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(beta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(gamma)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(delta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(eta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(zeta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(theta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(iota)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(kappa)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(mu)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_3d.cl b/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_3d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..ed3f4a397583984ef7b1b65a9ce6fa03b4e2e461
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/basic_vector_3d.cl
@@ -0,0 +1,121 @@
+/**
+ * @file basic_vector_3d.cl
+ * Remeshing function, vectorized version for vector remeshing in 3D.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y, float__N__ v_Z,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,float__N__ v_Z,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc){
+ float__N__ y; /* Normalized distance to nearest left grid point */
+ int__N__ ind; /* Integer coordinate */
+ uint__N__ index; /* Remeshing index */
+ float w__NN__;
+
+ ind = convert_int__N___rtn(p * invdx);
+ y = (p - convert_float__N__(ind) * dx) * invdx;
+
+ index = convert_uint__N__((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w__NN__ = REMESH(alpha)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(beta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(gamma)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(delta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(eta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(zeta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(theta)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(iota)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(kappa)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w__NN__ = REMESH(mu)(y.s__NN__);
+ gvec_X_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_X.s__NN__);
+ gvec_Y_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Y.s__NN__);
+ gvec_Z_loc[noBC_id(index.s__NN__)] += (w__NN__ * v_Z.s__NN__);
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/private_vector_2d.cl b/HySoP/hysop/gpu/cl_src/remeshing/private_vector_2d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..fcb1e443c40e568e7ba9c665659f6936343509c1
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/private_vector_2d.cl
@@ -0,0 +1,112 @@
+/**
+ * @file private_vector_2d.cl
+ * Remeshing function, vectorized, private variable for 2D vector remeshing.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ * Use of a private temporary variable for remeshing weights.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc){
+ float__N__ y, /* Normalized distance to nearest left grid point */
+ w; /* Temporary remeshing weights */
+ int__N__ ind; /* Integer coordinate */
+ uint__N__ index; /* Remeshing index */
+
+ ind = convert_int__N___rtn(p * invdx);
+ y = (p - convert_float__N__(ind) * dx) * invdx;
+
+ index = convert_uint__N__((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w = REMESH(alpha)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(beta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(gamma)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(delta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w = REMESH(eta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(zeta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w = REMESH(theta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(iota)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w = REMESH(kappa)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(mu)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/cl_src/remeshing/private_vector_3d.cl b/HySoP/hysop/gpu/cl_src/remeshing/private_vector_3d.cl
new file mode 100644
index 0000000000000000000000000000000000000000..dabd8e5d8dc285696a5129933adf1da1b759f4b3
--- /dev/null
+++ b/HySoP/hysop/gpu/cl_src/remeshing/private_vector_3d.cl
@@ -0,0 +1,122 @@
+/**
+ * @file private_vector_3d.cl
+ * Remeshing function, vectorized, private variable for 3D vector remeshing.
+ */
+
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,float__N__ v_Z,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc);
+
+
+/**
+ * Remesh particles in local buffer.
+ *
+ * Remeshing formula is given a compiling time.
+ * Use of builtin OpenCL functions fma and mix. Computations through OpenCL vector types.
+ * Use of a private temporary variable for remeshing weights.
+ *
+ * @param i Particle index
+ * @param dx Space step
+ * @param invdx 1/dx
+ * @param s Particle scalar
+ * @param p Particle position
+ * @param gscal_loc Local buffer for result
+ *
+ * @remark <code>NB_I</code>, <code>NB_II</code>, <code>NB_III</code> : points number in directions from 1st varying index to last.
+ * @remark <code>__N__</code> is expanded at compilation time by vector width.
+ * @remark <code>__NN__</code> is expanded at compilation time by a sequence of integer for each vector component.
+ * @remark <code>FORMULA</code> : remeshing formula flag {<code>M4PRIME</code>, <code>M6PRIME</code>, <code>M8PRIME</code>, <code>L6STAR</code>}
+ * @remark <code>REMESH</code> is a function-like macro expanding to the proper remeshing formula (i.e.: <code>REMESH(alpha)</code> -> <code>alpha_l2_1</code>)
+ * @see parmepy.gpu.tools.parse_file
+ * @see parmepy.gpu.cl_src.common
+ */
+void remesh(uint i, float dx, float invdx,
+ float__N__ v_X, float__N__ v_Y,float__N__ v_Z,
+ float__N__ p,
+ __local float* gvec_X_loc, __local float* gvec_Y_loc, __local float* gvec_Z_loc){
+ float__N__ y, /* Normalized distance to nearest left grid point */
+ w; /* Temporary remeshing weights */
+ int__N__ ind; /* Integer coordinate */
+ uint__N__ index; /* Remeshing index */
+
+ ind = convert_int__N___rtn(p * invdx);
+ y = (p - convert_float__N__(ind) * dx) * invdx;
+
+ index = convert_uint__N__((ind - REMESH_SHIFT + NB_I) % NB_I);
+
+ w = REMESH(alpha)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(beta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(gamma)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(delta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+#if REMESH_SHIFT > 1
+ index = (index + 1) % NB_I;
+ w = REMESH(eta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(zeta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 2
+ index = (index + 1) % NB_I;
+ w = REMESH(theta)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(iota)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+
+#if REMESH_SHIFT > 3
+ index = (index + 1) % NB_I;
+ w = REMESH(kappa)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ index = (index + 1) % NB_I;
+ w = REMESH(mu)(y);
+ gvec_X_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_X.s__NN__;
+ gvec_Y_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Y.s__NN__;
+ gvec_Z_loc[noBC_id(index.s__NN__)] += w.s__NN__ * v_Z.s__NN__;
+ barrier(CLK_LOCAL_MEM_FENCE);
+#endif
+}
diff --git a/HySoP/hysop/gpu/gpu_particle_advection_1k.py b/HySoP/hysop/gpu/gpu_particle_advection_1k.py
new file mode 100644
index 0000000000000000000000000000000000000000..fb52be095abf98ecc5b52f2c71c0d7c4b1b50665
--- /dev/null
+++ b/HySoP/hysop/gpu/gpu_particle_advection_1k.py
@@ -0,0 +1,237 @@
+"""
+@file gpu_particle_advection_1k.py
+
+Discrete advection representation.
+"""
+from parmepy.constants import debug, PARMES_REAL
+from parmepy.gpu.gpu_particle_advection import GPUParticleAdvection
+from parmepy.methods_keys import TimeIntegrator, Interpolation, Remesh, \
+ Support, Splitting, MultiScale
+from parmepy.numerics.integrators.runge_kutta2 import RK2
+from parmepy.numerics.interpolation import Linear
+from parmepy.numerics.remeshing import L2_1
+from parmepy.fields.continuous import Field
+from parmepy.gpu.gpu_discrete import GPUDiscreteField
+from parmepy.gpu.gpu_kernel import KernelLauncher
+
+
+class GPUParticleAdvection1k(GPUParticleAdvection):
+ """
+ Particle advection operator representation on GPU with a single kernel
+ for computing advection and remeshing.
+ """
+
+ @debug
+ def __init__(self, velocity, advectedFields, d,
+ part_position=None, part_advectedFields=None,
+ platform_id=None, device_id=None,
+ device_type=None,
+ method=None,
+ src=None, batch_nb=None,
+ isMultiScale=False):
+ """
+ Create a Advection operator.
+ Work on a given scalar at a given velocity to produce scalar
+ distribution at new positions.
+
+ @param velocity : Velocity field
+ @param advectedFields : Advected field (only single field is supported)
+ @param d : Direction to advect
+ @param part_position : DiscreteField to use for particle position.
+ @param part_advectedFields : DiscreteField to use for particle
+ advected fields.
+ @param platform_id : OpenCL platform id (default = 0).
+ @param device_id : OpenCL device id (default = 0).
+ @param device_type : OpenCL device type (default = 'gpu').
+ @param method : the method to use.
+ @param src : User OpenCL sources.
+ @param batch_nb : User defined batch number for fields (computed by
+ default to fit the device memory).
+ @param isMultiScale : Flag to specify if the velocity and advected
+ fields are on different grids.
+ """
+ if method is None:
+ method = {TimeIntegrator: RK2,
+ Interpolation: Linear,
+ Remesh: L2_1,
+ Support: 'gpu_1k',
+ Splitting: 'o2'}
+ GPUParticleAdvection.__init__(self, velocity, advectedFields, d,
+ part_position, part_advectedFields,
+ platform_id, device_id,
+ device_type,
+ method, src,
+ batch_nb,
+ isMultiScale=isMultiScale)
+ self.num_advec_and_remesh = None
+
+ @debug
+ def setUp(self):
+ GPUParticleAdvection.setUp(self)
+
+ def globalMemoryUsagePreview(self, v_shape, shape):
+ r = (self.velocity.nbComponents * v_shape.prod() +
+ 2 * self.advectedFields[0].nbComponents * shape.prod())
+ return r * self.cl_env.prec_size
+
+ def _buffer_allocations(self):
+ """
+ Allocate OpenCL buffers for velocity and advected field.
+ And one more buffer for advected fields quantities on particles.
+ """
+ ## Velocity.
+ alloc = not isinstance(self.velocity, GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env, self.velocity,
+ self.gpu_precision,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.velocity.mem_size
+
+ ## Transported field.
+ alloc = not isinstance(self.advectedFields[0], GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env,
+ self.advectedFields[0],
+ self.gpu_precision,
+ layout=False,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.advectedFields[0].mem_size
+
+ ## Result scalar
+ if self.part_advectedFields is None:
+ self.part_advectedFields = [
+ Field(self.advectedFields[0].topology.domain,
+ name="Particle_AdvectedFields",
+ isVector=self.advectedFields[0].isVector
+ ).discretize(self.advectedFields[0].topology)]
+ alloc = not isinstance(self.part_advectedFields[0], GPUDiscreteField)
+ GPUDiscreteField.fromField(
+ self.cl_env, self.part_advectedFields[0],
+ self.gpu_precision,
+ layout=False,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.part_advectedFields[0].mem_size
+
+ is_batch = (self.velocity.isBatch and
+ self.advectedFields[0].isBatch and
+ self.part_advectedFields[0].isBatch)
+ is_not_batch = (not self.velocity.isBatch and
+ not self.advectedFields[0].isBatch and
+ not self.part_advectedFields[0].isBatch)
+ identic_batch = True
+ if is_batch:
+ for vb, adb, padb in zip(
+ self.velocity.batch_nb[self.dir],
+ self.advectedFields[0].batch_nb[self.dir],
+ self.part_advectedFields[0].batch_nb[self.dir]):
+ identic_batch = identic_batch and (vb == adb and vb == padb)
+
+ if not ((is_batch or is_not_batch) and
+ (not is_batch or (is_batch and identic_batch))):
+ raise RuntimeError("In operator advection on GPU, automatic " +
+ "batch number computations fails: (different " +
+ "batch number for same variables use in " +
+ "different advection operators). " +
+ "User must give an explicit and identical " +
+ "batch_nb parameter for all GPU advection " +
+ "operators")
+
+ self.variables = [self.advectedFields[0], self.velocity,
+ self.part_advectedFields[0]]
+ self._work = self.part_advectedFields
+
+ def _collect_kernels_cl_src(self):
+ """
+ Compile OpenCL sources for advection and remeshing kernel.
+ """
+ build_options = self.build_options + self._size_constants
+ src, is_noBC, vec, f_space = self._kernel_cfg['advec_and_remesh']
+ gwi, lwi = f_space(self.resol_dir, vec)
+ WINb = lwi[0]
+ build_options += " -D FORMULA=" + self.method[Remesh].__name__.upper()
+ if self._isMultiScale:
+ build_options += " -D MS_FORMULA="
+ build_options += self.method[MultiScale].__name__.upper()
+ if is_noBC:
+ build_options += " -D WITH_NOBC=1"
+ build_options += " -D WI_NB=" + str(WINb)
+ build_options += " -D PART_NB_PER_WI="
+ build_options += str(self.resol_dir[0] / WINb)
+ build_options += self._constants[self.dir]
+ ## Build code
+ src = [s.replace('RKN', self.method[TimeIntegrator].__name__.lower())
+ for s in src]
+ prg = self.cl_env.build_src(
+ src, build_options, vec,
+ nb_remesh_components=self.part_advectedFields[0].nbComponents)
+ self.num_advec_and_remesh = KernelLauncher(
+ prg.advection_and_remeshing, self.cl_env.queue, gwi, lwi)
+
+ ## Local memory array for kernels
+ advec_nbC = self.part_advectedFields[0].nbComponents
+ loc_arrays = [self.v_resol_dir[0]]
+ loc_arrays += [self.resol_dir[0]] * (advec_nbC)
+ self._num_locMem, self.size_local_alloc = \
+ self.cl_env.LocalMemAllocator(loc_arrays)
+
+ def _compute_1c(self, simulation, dtCoeff, split_id, old_dir):
+ dt = simulation.timeStep * dtCoeff
+ wait_evts = self.velocity.events + \
+ self.part_advectedFields[0].events + \
+ self.advectedFields[0].events
+ evt = self.num_advec_and_remesh(
+ self.velocity.gpu_data[self.dir].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self._num_locMem[0], self._num_locMem[1],
+ self.gpu_precision(dt),
+ self.coord_min[self.dir],
+ self.mesh_size, self.v_mesh_size,
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def _compute_2c(self, simulation, dtCoeff, split_id, old_dir):
+ dt = simulation.timeStep * dtCoeff
+ wait_evts = self.velocity.events + \
+ self.part_advectedFields[0].events + \
+ self.advectedFields[0].events
+ evt = self.num_advec_and_remesh(
+ self.velocity.gpu_data[self.dir].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[1].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[1].data,
+ self._num_locMem[0], self._num_locMem[1], self._num_locMem[2],
+ self.gpu_precision(dt),
+ self.coord_min[self.dir],
+ self.mesh_size, self.v_mesh_size,
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def _compute_3c(self, simulation, dtCoeff, split_id, old_dir):
+ dt = simulation.timeStep * dtCoeff
+ wait_evts = self.velocity.events + \
+ self.part_advectedFields[0].events + \
+ self.advectedFields[0].events
+ evt = self.num_advec_and_remesh(
+ self.velocity.gpu_data[self.dir].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[1].data,
+ self.part_advectedFields[0].gpu_data[2].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[1].data,
+ self.advectedFields[0].gpu_data[2].data,
+ self._num_locMem[0], self._num_locMem[1],
+ self._num_locMem[2], self._num_locMem[3],
+ self.gpu_precision(dt),
+ self.coord_min[self.dir],
+ self.mesh_size, self.v_mesh_size,
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def finalize(self):
+ if self.num_advec_and_remesh.f_timer is not None:
+ for f_timer in self.num_advec_and_remesh.f_timer:
+ self.kernels_timer.addFunctionTimer(f_timer)
+ GPUParticleAdvection.finalize(self)
diff --git a/HySoP/hysop/gpu/gpu_particle_advection_2k.py b/HySoP/hysop/gpu/gpu_particle_advection_2k.py
new file mode 100644
index 0000000000000000000000000000000000000000..85fd35b6cba08f95dc5459d6722d3c35b067d8ae
--- /dev/null
+++ b/HySoP/hysop/gpu/gpu_particle_advection_2k.py
@@ -0,0 +1,281 @@
+"""
+@file gpu_particle_advection_2k.py
+
+Discrete advection representation.
+"""
+from parmepy.constants import debug, PARMES_REAL
+from parmepy.gpu.gpu_particle_advection import GPUParticleAdvection
+from parmepy.methods_keys import TimeIntegrator, Interpolation, Remesh, \
+ Support, Splitting, MultiScale
+from parmepy.numerics.integrators.runge_kutta2 import RK2
+from parmepy.numerics.interpolation import Linear
+from parmepy.numerics.remeshing import L2_1
+from parmepy.fields.continuous import Field
+from parmepy.gpu.gpu_discrete import GPUDiscreteField
+from parmepy.gpu.gpu_kernel import KernelLauncher
+
+
+class GPUParticleAdvection2k(GPUParticleAdvection):
+ """
+ Particle advection operator representation on GPU.
+ """
+
+ @debug
+ def __init__(self, velocity, advectedFields, d,
+ part_position=None, part_advectedFields=None,
+ platform_id=None, device_id=None,
+ device_type=None,
+ method=None,
+ src=None, batch_nb=None,
+ isMultiScale=False):
+ """
+ Create a Advection operator.
+ Work on a given scalar at a given velocity to produce scalar
+ distribution at new positions.
+
+ @param velocity : Velocity field
+ @param advectedFields : Advected field (only single field is supported)
+ @param d : Direction to advect
+ @param part_position : DiscreteField to use for particle position.
+ @param part_advectedFields : DiscreteField to use for particle
+ advected fields.
+ @param platform_id : OpenCL platform id (default = 0).
+ @param device_id : OpenCL device id (default = 0).
+ @param device_type : OpenCL device type (default = 'gpu').
+ @param method : the method to use.
+ @param src : User OpenCL sources.
+ @param batch_nb : User defined batch number for fields (computed by
+ default to fit the device memory).
+ @param isMultiScale : Flag to specify if the velocity and advected
+ fields are on different grids.
+ """
+ if method is None:
+ method = {TimeIntegrator: RK2,
+ Interpolation: Linear,
+ Remesh: L2_1,
+ Support: 'gpu_2k',
+ Splitting: 'o2'}
+ GPUParticleAdvection.__init__(self, velocity, advectedFields, d,
+ part_position, part_advectedFields,
+ platform_id, device_id,
+ device_type,
+ method, src,
+ batch_nb,
+ isMultiScale=isMultiScale)
+ self.num_advec, self.num_remesh = None, None
+
+ @debug
+ def setUp(self):
+ GPUParticleAdvection.setUp(self)
+
+ def globalMemoryUsagePreview(self, v_shape, shape):
+ r = (self.velocity.nbComponents * v_shape.prod() +
+ (2 * self.advectedFields[0].nbComponents + 1) * shape.prod())
+ return r * self.cl_env.prec_size
+
+ def _buffer_allocations(self):
+ """
+ Allocate OpenCL buffers for velocity and advected field.
+ And one more buffer for advected fields quantities on particles.
+ And a buffer for storing particle positions.
+ """
+ ## Velocity.
+ alloc = not isinstance(self.velocity, GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env, self.velocity,
+ self.gpu_precision,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.velocity.mem_size
+
+ ## Transported field.
+ alloc = not isinstance(self.advectedFields[0], GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env, self.advectedFields[0],
+ self.gpu_precision,
+ layout=False,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.advectedFields[0].mem_size
+
+ ## Particle position
+ if self.part_position is None:
+ self.part_position = \
+ Field(self.advectedFields[0].topology.domain,
+ name="Particle_Position",
+ isVector=False
+ ).discretize(self.advectedFields[0].topology)
+ alloc = not isinstance(self.part_position, GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env, self.part_position,
+ self.gpu_precision, layout=False,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.part_position.mem_size
+
+ ## Result scalar
+ if self.part_advectedFields is None:
+ self.part_advectedFields = [
+ Field(self.advectedFields[0].topology.domain,
+ name="Particle_AdvectedFields",
+ isVector=self.advectedFields[0].isVector
+ ).discretize(self.advectedFields[0].topology)]
+ alloc = not isinstance(self.part_advectedFields[0], GPUDiscreteField)
+ GPUDiscreteField.fromField(self.cl_env, self.part_advectedFields[0],
+ self.gpu_precision, layout=False,
+ batch_nb=self.batch_nb, batch_d=self.dir)
+ if alloc:
+ self.size_global_alloc += self.part_advectedFields[0].mem_size
+
+ is_batch = (self.velocity.isBatch and
+ self.advectedFields[0].isBatch and
+ self.part_position.isBatch and
+ self.part_advectedFields[0].isBatch)
+ is_not_batch = (not self.velocity.isBatch and
+ not self.advectedFields[0].isBatch and
+ not self.part_position.isBatch and
+ not self.part_advectedFields[0].isBatch)
+ identic_batch = True
+ if is_batch:
+ for vb, adb, pposb, padb in zip(
+ self.velocity.batch_nb[self.dir],
+ self.advectedFields[0].batch_nb[self.dir],
+ self.part_position.batch_nb[self.dir],
+ self.part_advectedFields[0].batch_nb[self.dir]):
+ identic_batch = identic_batch and \
+ (vb == adb and vb == padb and vb == pposb)
+
+ if not ((is_batch or is_not_batch) and
+ (not is_batch or (is_batch and identic_batch))):
+ raise RuntimeError("In operator advection on GPU, automatic " +
+ "batch number computations fails: (different " +
+ "batch number for same variables use in " +
+ "different advection operators). " +
+ "User must give an explicit and identical " +
+ "batch_nb parameter for all GPU advection " +
+ "operators")
+
+ self.variables = [self.advectedFields[0], self.velocity,
+ self.part_position, self.part_advectedFields[0]]
+ self._work = self.part_advectedFields + [self.part_position]
+
+ def _collect_kernels_cl_src(self):
+ """
+ Compile OpenCL sources for advection and remeshing kernel.
+ """
+ build_options = self.build_options + self._size_constants
+ src, is_noBC, vec, f_space = self._kernel_cfg['advec']
+ gwi, lwi = f_space(self.resol_dir, vec)
+ WINb = lwi[0]
+
+ if is_noBC:
+ build_options += " -D WITH_NOBC=1"
+ build_options += " -D WI_NB=" + str(WINb)
+ if self._isMultiScale:
+ build_options += " -D MS_FORMULA="
+ build_options += self.method[MultiScale].__name__.upper()
+ build_options += self._constants[self.dir]
+ ## Build code
+ src = [s.replace('RKN', self.method[TimeIntegrator].__name__.lower())
+ for s in src]
+ prg = self.cl_env.build_src(
+ src,
+ build_options,
+ vec,
+ nb_remesh_components=self.part_advectedFields[0].nbComponents)
+ self.num_advec = KernelLauncher(
+ prg.advection_kernel, self.cl_env.queue, gwi, lwi)
+
+ ## remeshing
+ build_options = self.build_options + self._size_constants
+ src, is_noBC, vec, f_space = self._kernel_cfg['remesh']
+ gwi, lwi = f_space(self.resol_dir, vec)
+ WINb = lwi[0]
+
+ build_options += " -D FORMULA=" + self.method[Remesh].__name__.upper()
+ if is_noBC:
+ build_options += " -D WITH_NOBC=1"
+ build_options += " -D WI_NB=" + str(WINb)
+ build_options += " -D PART_NB_PER_WI="
+ build_options += str(self.resol_dir[0] / WINb)
+ build_options += self._constants[self.dir]
+ ## Build code
+ prg = self.cl_env.build_src(
+ src, build_options, vec,
+ nb_remesh_components=self.part_advectedFields[0].nbComponents)
+ self.num_remesh = KernelLauncher(
+ prg.remeshing_kernel, self.cl_env.queue, gwi, lwi)
+
+ ## Local memory array for kernels
+ advec_nbC = self.part_advectedFields[0].nbComponents
+ loc_arrays = [self.v_resol_dir[0]]
+ loc_arrays += [self.resol_dir[0]] * (advec_nbC)
+ self._num_locMem, self.size_local_alloc = \
+ self.cl_env.LocalMemAllocator(loc_arrays)
+
+ def _compute_advec(self, simulation, dtCoeff, split_id, old_dir):
+ dt = simulation.timeStep * dtCoeff
+ wait_evts = self.velocity.events+self.part_position.events
+ # Advection
+ evt = self.num_advec(
+ self.velocity.gpu_data[self.dir].data,
+ self.part_position.gpu_data[0].data,
+ self._num_locMem[0],
+ self.gpu_precision(dt),
+ self.coord_min[self.dir],
+ self.mesh_size, self.v_mesh_size,
+ wait_for=wait_evts)
+ self.part_position.events.append(evt)
+
+ def _compute_1c(self, simulation, dtCoeff, split_id, old_dir):
+ self._compute_advec(simulation, dtCoeff, split_id, old_dir)
+ wait_evts = self.part_position.events+self.advectedFields[0].events
+ evt = self.num_remesh(
+ self.part_position.gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self._num_locMem[1],
+ self.coord_min[self.dir],
+ self.mesh_size[self.dir],
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def _compute_2c(self, simulation, dtCoeff, split_id, old_dir):
+ self._compute_advec(simulation, dtCoeff, split_id, old_dir)
+ wait_evts = self.part_position.events+self.advectedFields[0].events
+ evt = self.num_remesh(
+ self.part_position.gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[1].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[1].data,
+ self._num_locMem[1],
+ self._num_locMem[2],
+ self.coord_min[self.dir],
+ self.mesh_size[self.dir],
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def _compute_3c(self, simulation, dtCoeff, split_id, old_dir):
+ self._compute_advec(simulation, dtCoeff, split_id, old_dir)
+ wait_evts = self.part_position.events+self.advectedFields[0].events
+ evt = self.num_remesh(
+ self.part_position.gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[0].data,
+ self.part_advectedFields[0].gpu_data[1].data,
+ self.part_advectedFields[0].gpu_data[2].data,
+ self.advectedFields[0].gpu_data[0].data,
+ self.advectedFields[0].gpu_data[1].data,
+ self.advectedFields[0].gpu_data[2].data,
+ self._num_locMem[1],
+ self._num_locMem[2],
+ self._num_locMem[3],
+ self.coord_min[self.dir],
+ self.mesh_size[self.dir],
+ wait_for=wait_evts)
+ self.advectedFields[0].events.append(evt)
+
+ def finalize(self):
+ if self.num_advec.f_timer is not None:
+ for f_timer in self.num_advec.f_timer:
+ self.kernels_timer.addFunctionTimer(f_timer)
+ for f_timer in self.num_remesh.f_timer:
+ self.kernels_timer.addFunctionTimer(f_timer)
+ GPUParticleAdvection.finalize(self)
diff --git a/HySoP/hysop/mpi/tests/test_mesh.py b/HySoP/hysop/mpi/tests/test_mesh.py
new file mode 100644
index 0000000000000000000000000000000000000000..8f17c38e5bd0e3ba5ca3ead27f763bb2e5c09dc6
--- /dev/null
+++ b/HySoP/hysop/mpi/tests/test_mesh.py
@@ -0,0 +1,61 @@
+"""
+@file parmepy.mpi.tests.test_mesh
+Testing mesh.
+"""
+import numpy as np
+from parmepy.domain.box import Box
+from parmepy.mpi.topology import Cartesian
+
+
+def test_mesh3D():
+ """Periodic mesh"""
+ dom = Box()
+ resolTopo = [33, 33, 17]
+ topo = Cartesian(dom, 3, resolTopo)
+ topo.setUp()
+ dx = [1. / (n - 1) for n in resolTopo]
+ assert (topo.mesh.origin == [0. for n in resolTopo]).all()
+ assert (topo.mesh.end == [1. - dxx for dxx in dx]).all()
+ assert (topo.mesh.global_start == [0 for n in resolTopo]).all()
+ assert (topo.mesh.global_end == [n - 2 for n in resolTopo]).all()
+ assert (topo.mesh.local_start == [0 for n in resolTopo]).all()
+ assert (topo.mesh.local_end == [n - 2 for n in resolTopo]).all()
+ assert len(topo.mesh.coords) == 3
+ assert topo.mesh.coords[0].shape == (resolTopo[0] - 1, 1, 1)
+ assert topo.mesh.coords[1].shape == (1, resolTopo[1] - 1, 1)
+ assert topo.mesh.coords[2].shape == (1, 1, resolTopo[2] - 1)
+ assert topo.mesh.coords[0][1, 0, 0] == dx[0]
+ assert topo.mesh.coords[1][0, 1, 0] == dx[1]
+ assert topo.mesh.coords[2][0, 0, 1] == dx[2]
+
+
+def test_mesh3D_ghost():
+ """Periodic mesh"""
+ dom = Box()
+ resolTopo = [33, 33, 17]
+ dx = [1. / (n - 1) for n in resolTopo]
+ ghost = np.array([2, 2, 1])
+ topo = Cartesian(dom, 3, resolTopo, ghosts=ghost)
+ topo.setUp()
+ assert (topo.mesh.origin ==
+ [0. - g * dxx for dxx, g in zip(dx, ghost)]).all()
+ assert (topo.mesh.end ==
+ [1. - dxx + g * dxx for dxx, g in zip(dx, ghost)]).all()
+ assert (topo.mesh.global_start ==
+ [0 for n in resolTopo]).all()
+ assert (topo.mesh.global_end == [n - 2 for n in resolTopo]).all()
+ assert (topo.mesh.local_start == [g for g in ghost]).all()
+ assert (topo.mesh.local_end ==
+ [n - 2 + g for n, g in zip(resolTopo, ghost)]).all()
+ assert len(topo.mesh.coords) == 3
+ assert topo.mesh.coords[0].shape == (resolTopo[0] - 1 + 2 * ghost[0], 1, 1)
+ assert topo.mesh.coords[1].shape == (1, resolTopo[1] - 1 + 2 * ghost[1], 1)
+ assert topo.mesh.coords[2].shape == (1, 1, resolTopo[2] - 1 + 2 * ghost[2])
+ assert topo.mesh.coords[0][1, 0, 0] == (-ghost[0] + 1) * dx[0]
+ assert topo.mesh.coords[1][0, 1, 0] == (-ghost[1] + 1) * dx[1]
+ assert topo.mesh.coords[2][0, 0, 1] == (-ghost[2] + 1) * dx[2]
+
+# Todo : update tests for multi-proc mpi runs.
+#if __name__ == '__main__':
+# test_mesh3D()
+# test_mesh3D_ghost()
diff --git a/HySoP/hysop/operator/discrete/analytic.py b/HySoP/hysop/operator/discrete/analytic.py
new file mode 100644
index 0000000000000000000000000000000000000000..2c518f67517c1f6f6a32f25870f1851ff346c7da
--- /dev/null
+++ b/HySoP/hysop/operator/discrete/analytic.py
@@ -0,0 +1,45 @@
+"""
+@file discrete/analytic.py
+
+Apply user-defined formula to a set of discrete variables.
+"""
+from parmepy.constants import np, debug
+from discrete import DiscreteOperator
+from parmepy.tools.timers import timed_function
+
+
+class Analytic_D(DiscreteOperator):
+ """
+ Compute discrete fields values using a given analytic formula.
+ """
+
+ @debug
+ def __init__(self, variables, formula, doVectorize=False, method=None):
+ """
+ @param[in,out] variables : a list of discrete variables on which
+ formula must be applied.
+ @param[in] formula : user defined formula to be applied.
+ @param[in] doVectorize : true if formula must be vectorized
+ @param method : Method used
+ """
+ DiscreteOperator.__init__(self, variables, method)
+ self.output = variables
+ self.doVectorize = doVectorize
+ if self.doVectorize:
+ self.vformula = np.vectorize(formula)
+ else:
+ self.vformula = formula
+
+ @debug
+ @timed_function
+ def apply(self, simulation):
+ """
+ Initialize is always called with coords + current time.
+ Any extra parameters must be set using field.setExtraParameters.
+ """
+ if simulation is None:
+ raise ValueError("Missing simulation value for computation.")
+
+ for df in self.variables:
+ df.initialize(formula=self.vformula, doVectorize=self.doVectorize,
+ currentTime=simulation.time)
diff --git a/HySoP/hysop/operator/monitors/__init__.py b/HySoP/hysop/operator/monitors/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..5728a8fe9c9feff86bc390bdcd5eac0b1daacb57
--- /dev/null
+++ b/HySoP/hysop/operator/monitors/__init__.py
@@ -0,0 +1,19 @@
+## @package parmepy.operator.monitors
+# Parmes tools for data and fields monitoring.
+#
+# import and alias so that monitors are
+# available with
+# from parmepy.operators.monitors import Printer, ...
+import printer
+Printer = printer.Printer
+import compute_forces
+DragAndLift = compute_forces.DragAndLift
+import reprojection_criterion
+Reprojection_criterion = reprojection_criterion.Reprojection_criterion
+import energy_enstrophy as energy_enstrophy
+Energy_enstrophy = energy_enstrophy.Energy_enstrophy
+
+# Set list for 'import *'
+__all__ = ['DragAndLift', 'Energy_enstrophy',
+ 'Reprojection_criterion', 'Printer']
+
diff --git a/HySoP/hysop/operator/drag_and_lift.py b/HySoP/hysop/operator/monitors/compute_forces.py
similarity index 100%
rename from HySoP/hysop/operator/drag_and_lift.py
rename to HySoP/hysop/operator/monitors/compute_forces.py
diff --git a/HySoP/hysop/operator/monitors/monitoring.py b/HySoP/hysop/operator/monitors/monitoring.py
new file mode 100644
index 0000000000000000000000000000000000000000..852c87f97d0dacc28578f8c949d101778d74f3f0
--- /dev/null
+++ b/HySoP/hysop/operator/monitors/monitoring.py
@@ -0,0 +1,67 @@
+"""
+@file monitoring.py
+Global interface for monitors.
+"""
+from abc import ABCMeta, abstractmethod
+from parmepy.operator.continuous import Operator
+from parmepy.tools.timers import Timer
+import parmepy.tools.io_utils as io
+
+
+class Monitoring(Operator):
+ """Abstract interface to monitoring operators."""
+
+ __metaclass__ = ABCMeta
+
+ @abstractmethod
+ def __init__(self, io_params=None, **kwds):
+ """ Constructor
+ @param variables : list of fields to monitor.
+ @param topo : topo on which fields are to be monitored
+ @param filename output file name. Default is None ==> no output.
+ Full or relative path.
+ @param io_params : parameters (dict) to set file output.
+ If None, no output. Set io_params = {} if you want output,
+ with default parameters values.
+ See parmepy.tools.io_utils.Writer for details
+ """
+ super(Monitoring, self).__init__(**kwds)
+ assert self.topology is not None,\
+ 'A topology must be given explicitely during monitors init'
+ ## Object to store computational times of lower level functions
+ self.timer = Timer(self)
+ self.requirements = []
+ self._isUpToDate = False
+ ## Output file description
+ self.io_params = io_params
+ # Output file.
+ if io_params is None:
+ self._writer = None
+ else:
+ if self.topology is not None:
+ self._writer = io.Writer(io_params, self.topology.comm)
+
+ def setUp(self):
+ """
+ Class-method required
+ to fit with operator base-class interface.
+ """
+ self._isUpToDate = True
+
+ def finalize(self):
+ if self._writer is not None:
+ self._writer.finalize()
+
+ def discretize(self):
+ """
+ Does nothing.
+ No discretization in monitors, but class-method required
+ to fit with operator base-class interface.
+ """
+ pass
+
+ def addRedistributeRequirement(self, red):
+ self.requirements.append(red)
+
+ def getRedistributeRequirement(self):
+ return self.requirements
diff --git a/HySoP/hysop/operator/monitors/printer.py b/HySoP/hysop/operator/monitors/printer.py
new file mode 100644
index 0000000000000000000000000000000000000000..cd51aee3c4c0ae9dcb3322e7c2dd33a48fd6d849
--- /dev/null
+++ b/HySoP/hysop/operator/monitors/printer.py
@@ -0,0 +1,373 @@
+"""
+@file printer.py
+
+File output for field(s) value on a grid.
+"""
+from parmepy.constants import S_DIR, debug, VTK, HDF5, DATA
+from parmepy.operator.monitors.monitoring import Monitoring
+import parmepy.tools.numpywrappers as npw
+import parmepy.tools.io_utils as io
+import os
+from numpy import newaxis, float64
+
+try:
+ import evtk.hl as evtk
+except ImportError as evtk_error:
+ evtk = None
+try:
+ import h5py
+except ImportError as h5py_error:
+ h5py = None
+from parmepy.tools.timers import timed_function
+
+
+class Printer(Monitoring):
+ """
+ Print field(s) values on a given topo, in HDF5 or VTK format.
+ """
+ def __init__(self, prefix=None, frequency=1, formattype=None,
+ xmfalways=False, subset=None, **kwds):
+ """
+ Create a results printer for given fields, prefix
+ prefix (relative path) and an output frequency.
+
+ @param variables : list of variables to export.
+ @param frequency : output rate (output every freq iteration)
+ @param prefix output file name. Default is None ==> no output.
+ Full or relative path.
+ @param formattype : output file format, default=vtk.
+ @param xmfalways : true if xmf output must be done every time
+ an hdf5 file is created
+ """
+ super(Printer, self).__init__(**kwds)
+
+ assert frequency > 0
+ self.frequency = frequency
+ ## Default output type
+ if formattype is None:
+ self.formattype = VTK
+ else:
+ self.formattype = formattype
+ if self.formattype == VTK and evtk is None:
+ print ("You set a printer with VTK as format and evtk module ",)
+ print ("is not present. You must specify another format",)
+ print (" for output (DATA or HDF5)")
+ raise evtk_error
+ if self.formattype == HDF5 and h5py is None:
+ print ("You set a printer with HDF5 as format and h5py module ",)
+ print ("is not present. You must specify another extension",)
+ print (" (DATA or VTK)")
+ raise h5py_error
+
+ self.input = self.variables
+ self.output = []
+ # If no prefix is given, set it to
+ # the concatenation of variables'names.
+ if prefix is None:
+ prefix = io.io.defaultPath()
+ name = ''
+ for var in self.input:
+ name += var.name
+ name += '_'
+ prefix = os.path.join(prefix, name)
+ else:
+ if not os.path.isabs(prefix):
+ prefix = os.path.join(io.io.defaultPath(), prefix)
+ if self.topology is not None:
+ io.io.checkDir(prefix, 0, self.topology.comm)
+ self.prefix = prefix
+ self._xmf_data_files = []
+ if self.formattype == VTK:
+ # filename = prefix_rk_N, rk = current process rank,
+ # N = counter value
+ self._get_filename = lambda i: self.prefix + \
+ "_{0}_{1:05d}".format(self.topology.rank, i)
+ self.step = self._step_VTK
+ elif self.formattype == HDF5:
+ # filename = prefix_N, N = counter value
+ self._get_filename = lambda i: self.prefix + \
+ "_{0:05d}".format(i) + '.h5'
+ self.step = self._step_HDF5
+ if xmfalways:
+ self.step = self._step_HDF5_XMF
+ elif self.formattype == DATA:
+ self._get_filename = lambda i: self.prefix + \
+ "_{0}_{1:05d}.dat".format(self.topology.rank, i)
+ self.step = self._step_DATA
+ self._isUpToDate = True
+ # count the number of calls
+ self._count = 0
+ ## Rank of 'leader' mpi process for output
+ ## Forced to 0. \todo : add a param for this?
+ self.io_rank = 0
+
+ ## Set a subset of the original domain, to reduce
+ ## output
+ self.subset = subset
+ if self.subset is not None:
+ self.subset.discretize(self.topology)
+ self._slices = self.subset.slices[self.topology]
+ # Global resolution for hdf5 output
+ self.globalResolution = self.subset.globalResolution(self.topology)
+ else:
+ self.globalResolution = list(self.topology.globalMeshResolution - 1)
+ self._slices = self.topology.mesh.iCompute
+ self.globalResolution.reverse()
+
+ @debug
+ @timed_function
+ def apply(self, simulation=None):
+ if simulation is None:
+ raise ValueError("Missing simulation value for monitoring.")
+
+ if simulation.currentIteration == -1 or \
+ simulation.currentIteration % self.frequency == 0:
+ # Transfer from GPU to CPU if required
+ for f in self.variables:
+ df = f.discreteFields[self.topology]
+ try:
+ if not df.isBatch:
+ # To host only if data fit in the device memory
+ df.toHost()
+ df.wait()
+ except AttributeError:
+ pass
+ self.step(simulation)
+ self._count += 1
+
+ def createXMFFile(self):
+ if self.formattype == HDF5 and self.topology.rank == self.io_rank:
+ # Write the xmf file driving all h5 files.
+ # Writing only one file
+ # We have a temporal list of Grid => a single xmf file
+ # Manual writing of the xmf file because "XDMF library very
+ # difficult to compile and to use"
+ # [Advanced HDF5 & XDMF - Groupe Calcul]
+ f = open(self.prefix + '.xmf', 'w')
+ f.write("<?xml version=\"1.0\" ?>\n")
+ f.write("<!DOCTYPE Xdmf SYSTEM \"Xdmf.dtd\">\n")
+ f.write("<Xdmf Version=\"2.0\">\n")
+ f.write(" <Domain>\n")
+ f.write(" <Grid Name=\"CellTime\" GridType=\"Collection\" ")
+ f.write("CollectionType=\"Temporal\">\n")
+ for ds_names, i, t in self._xmf_data_files:
+ f.write(_TemporalGridXMF(
+ self.topology, ds_names, i, t, self._get_filename(i),
+ self.subset))
+ f.write(" </Grid>\n")
+ f.write(" </Domain>\n")
+ f.write("</Xdmf>\n")
+ f.close()
+
+ def finalize(self):
+ self.createXMFFile()
+ Monitoring.finalize(self)
+
+ def _build_vtk_dict(self):
+ """Build a dictionary from fields to VTK image."""
+ res = {}
+
+ for f in self.variables:
+ df = f.discreteFields[self.topology]
+ #ind = df.topology.mesh.iCompute
+ for d in xrange(df.nbComponents):
+ if f.isVector:
+ name = df.name + S_DIR[d]
+ else:
+ name = df.name
+ if len(df.data[d].shape) == 2:
+ res[name] = npw.realarray(df.data[d][:, :, newaxis])
+ else:
+ res[name] = npw.realarray(df.data[d])
+ return res
+
+ def _step_VTK(self, simu):
+ """
+ """
+ orig = [0.] * 3
+ dim = self.topology.mesh.dim
+ orig[:dim] = [self.topology.mesh.origin[i] for i in xrange(dim)]
+ #orig = tuple(orig)
+ #ind = self.topology.mesh.local_start
+ ## orig = tuple([self.topology.mesh.coords[i].flatten()[ind[i]]
+ ## for i in xrange(self.topology.mesh.dim)])
+ spacing = [0] * 3
+ spacing[:dim] = [self.topology.mesh.space_step[i] for i in xrange(dim)]
+ evtk.imageToVTK(self._get_filename(self._count),
+ origin=orig, spacing=spacing,
+ pointData=self._build_vtk_dict())
+
+ def _step_HDF5(self, simu):
+ t = simu.time
+ filename = self._get_filename(self._count)
+ # Write the h5 file
+ # (force np.float64, ParaView seems to not be able to read float32)
+ # Writing compressed hdf5 files (gzip compression seems the best)
+ # In parallel, one file is written, thus filename no longe contains
+ # mpi rank.
+ # TODO: Why gzip compression not working in parallel ??
+ # Remark: h5py must be build with --mpi option
+ if self.topology.size == 1:
+ f = h5py.File(filename, "w")
+ compression = 'gzip'
+ else:
+ f = h5py.File(filename, 'w', driver='mpio', comm=self.topology.comm)
+ compression = None
+ # It's necessary to compute the set of indices of the current subset
+ # in global notation
+ if self.subset is None:
+ # Note : g_start and g_end do not include ghost points.
+ g_start = self.topology.mesh.global_start
+ g_end = self.topology.mesh.global_end + 1
+ sl = [slice(g_start[i], g_end[i])
+ for i in xrange(self.domain.dimension)]
+ else:
+ g_start = self.subset.gstart
+ # convert self._slices to global position in topo
+ sl = self.topology.toIndexGlobal(self._slices)
+ # And shift using global position of the surface
+ sl = [slice(sl[i].start - g_start[i], sl[i].stop - g_start[i])
+ for i in xrange(self.domain.dimension)]
+ sl.reverse()
+ sl = tuple(sl)
+ datasetNames = []
+ for field in self.variables:
+ df = field.discreteFields[self.topology]
+ for d in xrange(df.nbComponents):
+ # creating datasets for the vector field
+ currentName = df.name + S_DIR[d]
+ datasetNames.append(currentName)
+ ds = f.create_dataset(currentName,
+ self.globalResolution,
+ dtype=float64,
+ compression=compression)
+ # In parallel, each proc must write in the proper part
+ # Of the dataset (of site global resolution)
+ ds[sl] = npw.realarray(df.data[d][self._slices].T)
+
+ self._xmf_data_files.append((datasetNames, self._count, t))
+
+ f.close()
+
+ def _step_HDF5_XMF(self, simu):
+ self._step_HDF5(simu)
+ self.createXMFFile()
+
+ def _step_DATA(self, simu):
+ f = open(self._get_filename(self._count), 'w')
+ shape = self.topology.mesh.resolution
+ coords = self.topology.mesh.coords
+ pbDimension = self.domain.dimension
+ if pbDimension == 2:
+ if len(shape) == 2:
+ for i in xrange(shape[0] - 1):
+ for j in xrange(shape[1] - 1):
+ f.write("{0:8.12} {1:8.12} ".format(
+ coords[0][i, 0], coords[1][0, j]))
+ for field in self.variables:
+ df = field.discreteFields[self.topology]
+ if field.isVector:
+ f.write("{0:8.12} {1:8.12} ".format(
+ df[0][i, j],
+ df[1][i, j]))
+ else:
+ f.write("{0:8.12} ".format(
+ df[0][i, j]))
+ f.write("\n")
+ elif pbDimension == 3:
+ for i in xrange(shape[0] - 1):
+ for j in xrange(shape[1] - 1):
+ for k in xrange(shape[2] - 1):
+ f.write(
+ "{0:8.12} {1:8.12} {2:8.12} ".format(
+ coords[0][i, 0, 0],
+ coords[1][0, j, 0],
+ coords[2][0, 0, k]))
+ for field in self.variables:
+ df = field.discreteFields[self.topology]
+ if field.isVector:
+ f.write(
+ "{0:8.12} {1:8.12} " +
+ "{2:8.12} ".format(
+ df[0][i, j, k],
+ df[1][i, j, k],
+ df[2][i, j, k]))
+ else:
+ f.write("{0:8.12} ".format(
+ df[0][i, j, k]))
+ f.write("\n")
+ else:
+ for i in xrange(shape[0] - 1):
+ f.write("{0:8.12} ".format(coords[0][i]))
+ for field in self.variables:
+ df = field.discreteFields[self.topology]
+ if field.isVector:
+ f.write(
+ "{0:8.12} ".format(df[0][i]))
+ else:
+ f.write("{0:8.12} ".format(df[i]))
+ f.write("\n")
+ f.close()
+
+
+def _listFormat(l):
+ """
+ Format a list to the xml output.
+ Removes the '[]()' and replace ',' with ' ' in default str.
+ @param l : list to format
+ """
+ return str(l).replace(',', ' ').replace('[', '').replace(']', '').replace(
+ '(', '').replace(')', '')
+
+
+def _TemporalGridXMF(topo, datasetNames, ite, t, filename, subset=None):
+ g = ""
+ dimension = topo.mesh.dim
+ if dimension == 2:
+ topoType = "2DCORECTMesh"
+ geoType = "ORIGIN_DXDY"
+ elif dimension == 3:
+ topoType = "3DCORECTMesh"
+ geoType = "ORIGIN_DXDYDZ"
+ g += " <Grid Name=\"Iteration {0:03d}\"".format(ite)
+ g += " GridType=\"Uniform\">\n"
+ g += " <Time Value=\"{0}\" />\n".format(t)
+ g += " <Topology TopologyType=\"" + str(topoType) + "\""
+ g += " NumberOfElements=\""
+ if subset is not None:
+ resolution = subset.gRes
+ else:
+ resolution = list(topo.globalMeshResolution - 1)
+ resolution.reverse()
+ g += _listFormat(resolution) + " \"/>\n"
+ g += " <Geometry GeometryType=\"" + geoType + "\">\n"
+ g += " <DataItem Dimensions=\"" + str(dimension) + " \""
+ g += " NumberType=\"Float\" Precision=\"4\" Format=\"XML\">\n"
+ if subset is not None:
+ ori = list(subset.origin)
+ else:
+ ori = list(topo.domain.origin)
+ ori.reverse()
+ g += " " + _listFormat(ori) + "\n"
+ g += " </DataItem>\n"
+ g += " <DataItem Dimensions=\"" + str(dimension) + " \""
+ g += " NumberType=\"Float\" Precision=\"8\" Format=\"XML\">\n"
+ step = list(topo.mesh.space_step)
+ step.reverse()
+ g += " " + _listFormat(step) + "\n"
+ g += " </DataItem>\n"
+ g += " </Geometry>\n"
+ for name in datasetNames:
+ g += " <Attribute Name=\""
+ g += name + "\""
+ g += " AttributeType=\"Scalar\" Center=\"Node\">\n"
+ g += " <DataItem Dimensions=\""
+ g += _listFormat(resolution) + " \""
+ g += " NumberType=\"Float\" Precision=\"8\" Format=\"HDF\""
+ g += " Compression=\"Raw\">\n" #
+ g += " " + filename.split('/')[-1]
+ g += ":/" + name
+ g += "\n </DataItem>\n"
+ g += " </Attribute>\n"
+ g += " </Grid>\n"
+ return g
diff --git a/HySoP/hysop/operator/monitors/reader.py b/HySoP/hysop/operator/monitors/reader.py
new file mode 100644
index 0000000000000000000000000000000000000000..9241f3957cc34e06631ee6b32b04d512c51fa3b0
--- /dev/null
+++ b/HySoP/hysop/operator/monitors/reader.py
@@ -0,0 +1,141 @@
+"""
+@file reader.py
+
+File output for field(s) value on a grid.
+"""
+from parmepy.constants import debug, HDF5
+from parmepy.operator.monitors.monitoring import Monitoring
+import parmepy.tools.io_utils as io
+import os
+
+try:
+ import h5py
+except ImportError as h5py_error:
+ h5py = None
+from parmepy.tools.timers import timed_function
+
+
+class Reader(Monitoring):
+ """
+ Print field(s) values on a given topo, in HDF5 or VTK format.
+ """
+ def __init__(self, prefix, formattype=None, subset=None, names=None,
+ **kwds):
+ """
+ @param variables : list of variables to read.
+ @param prefix input file name (without ext)
+ @param formattype : input file format, default=HDF5.
+ """
+ super(Reader, self).__init__(**kwds)
+ ## Default output type
+ if formattype is None:
+ self.formattype = HDF5
+ else:
+ self.formattype = formattype
+ if self.formattype is not HDF5:
+ raise ValueError("Format not allowed : only HDF5\
+ readers are implemented.")
+ if self.formattype == HDF5 and h5py is None:
+ print ("You set a printer with HDF5 as format and h5py module ",)
+ print ("is not present. You must specify another extension",)
+ print (" (DATA or VTK)")
+ raise h5py_error
+
+ self.input = self.variables
+ self.output = self.variables
+ if not os.path.isabs(prefix):
+ prefix = os.path.join(io.io.defaultPath(), prefix)
+
+ if self.topology is not None:
+ io.io.checkDir(prefix, 0, self.topology.comm)
+ self.prefix = prefix
+ self._isUpToDate = True
+ ## Set a subset of the original domain, to reduce
+ ## output
+ self.subset = subset
+ if self.subset is not None:
+ self.subset.discretize(self.topology)
+ self._slices = self.subset.slices[self.topology]
+ # Global resolution for hdf5 output
+ self.globalResolution = self.subset.globalResolution(self.topology)
+ else:
+ self.globalResolution = list(self.topology.globalMeshResolution - 1)
+ self._slices = self.topology.mesh.iCompute
+ self.globalResolution.reverse()
+ self.step = self.readHDF5
+ filename = self.prefix + '.h5'
+ assert os.path.isfile(filename), 'error, file does not exists'
+ if self.topology.size == 1:
+ self._file = h5py.File(filename, "r")
+ else:
+ self._file = h5py.File(filename, 'r', driver='mpio',
+ comm=self.topology.comm)
+ self._globalSlice = []
+ if self.subset is None:
+ # Note : g_start and g_end do not include ghost points.
+ g_start = self.topology.mesh.global_start
+ g_end = self.topology.mesh.global_end + 1
+ self._globalSlice = [slice(g_start[i], g_end[i])
+ for i in xrange(self.domain.dimension)]
+ else:
+ g_start = self.subset.gstart
+ # convert self._slices to global position in topo
+ self._globalSlice = self.topology.toIndexGlobal(self._slices)
+ # And shift using global position of the surface
+ self._globalSlice = [slice(self._globalSlice[i].start - g_start[i],
+ self._globalSlice[i].stop - g_start[i])
+ for i in xrange(self.domain.dimension)]
+ self._globalSlice.reverse()
+ self._globalSlice = tuple(self._globalSlice)
+ if names is None:
+ self.names = {}
+ names = self.dataset_names()
+ i = 0
+ for field in self.variables:
+ self.names[field] = []
+ for d in xrange(field.nbComponents):
+ self.names[field].append(names[i])
+ i += 1
+ else:
+ self.names = names
+ for field in self.variables:
+ fname = self.names[field]
+ self.names[field] = [v for v in self.dataset_names()
+ if fname in v]
+ # assert len(self.names[field]) == field.nbComponents
+
+ @debug
+ @timed_function
+ def apply(self, simulation=None):
+ self.step()
+
+ def dataset_names(self):
+ """
+ Return the list of available names for datasets in
+ the required file.
+ """
+ return self._file.keys()
+
+ def readHDF5(self):
+ # It's necessary to compute the set of indices of the current subset
+ # in global notation
+ for field in self.variables:
+ df = field.discreteFields[self.topology]
+ for d in xrange(df.nbComponents):
+ # creating datasets for the vector field
+ #currentName = df.name + S_DIR[d]
+ #if not currentName in f.iterkeys():
+ # raise ValueError("The required field name is \
+ # not in HDF5 file.")
+ #Note FP : temp method --> use the first name is dataset
+ # as data for field. Todo : set a list of names
+ # to be downloaded.
+ currentName = self.names[field][d]
+ ds = self._file[currentName]
+ # In parallel, each proc must write in the proper part
+ # Of the dataset (of site global resolution)
+ df.data[d][self._slices] = ds[self._globalSlice].T
+
+ def finalize(self):
+ Monitoring.finalize(self)
+ self._file.close()
diff --git a/HySoP/hysop/operator/redistribute_intercomm.py b/HySoP/hysop/operator/redistribute_intercomm.py
new file mode 100644
index 0000000000000000000000000000000000000000..bb223b9e4bdf670332fc211d3f53f87c25add87b
--- /dev/null
+++ b/HySoP/hysop/operator/redistribute_intercomm.py
@@ -0,0 +1,343 @@
+"""
+@file redistribute_intercomm.py
+Setup for data transfer/redistribution between a single parmes topology based
+on different MPI communicators with null intersection (for example
+by Comm_Split). One of the topology is labeled as the source and the other is
+the destination.
+
+It relies on a Bridge_intercomm.
+"""
+from parmepy.constants import debug, PARMES_MPI_REAL, ORDERMPI, S_DIR, np
+from parmepy import __VERBOSE__
+from parmepy.operator.continuous import Operator
+from parmepy.mpi.topology import Bridge_intercomm
+from parmepy.methods_keys import Support
+
+
+class RedistributeIntercomm(Operator):
+ """
+ Interconnection between two topologies on different sub set of MPI process.
+ SetUp will compute a Bridge_intercomm between a single topology.
+ Transfers data from topology of id_from to the id_to.
+ """
+ @debug
+ def __init__(self, op_from, op_to, proc_tasks,
+ parent_comm, component=None, name_suffix='', **kwds):
+ """
+ Create an operator to distribute data between two mpi topologies for a
+ list of variables.
+
+ @param variables : the set of variables to be redistributed
+ @param topo : Parmes topology that differs across process of the
+ parent_comm MPI intracommunicator.
+ @param id_from : id of the task considered as input.
+ @param id_to : id of the task considered as output.
+ @param proc_tasks: python array specifying the task id of each of
+ the parent_comm MPI intracommunicator.
+ @param parent_comm : Parent communicator (Each process that use this
+ operator must be a member of the parent_comm)
+ @param component : Component to consider.
+ @remark : proc_tasks size and number of processus in parent_comm
+ must be equal.
+ """
+ super(RedistributeIntercomm, self).__init__(**kwds)
+ vars_str = "_("
+ for vv in self.variables:
+ vars_str += vv.name + ","
+ vars_str = vars_str[:-1] + ')'
+ if not component is None:
+ vars_str += S_DIR[component]
+ self.name += vars_str+name_suffix
+ assert parent_comm.Get_size() == len(proc_tasks), \
+ "Parent communicator ({0})".format(parent_comm.Get_size()) + \
+ " and size of the task id array " + \
+ "({0}) are not equal".format(len(proc_tasks))
+ self.opFrom = op_from
+ self.opTo = op_to
+ self.id_from = self.opFrom.task_id
+ self.id_to = self.opTo.task_id
+ self.parent_comm = parent_comm
+ self._dim = self.variables[0].domain.dimension
+ self.proc_tasks = proc_tasks
+ self.input = self.output = self.variables
+ self.component = component
+ if component is None:
+ # All components are considered
+ self._range_components = lambda v: range(v.nbComponents)
+ else:
+ # Only the given component is considered
+ self._range_components = lambda v: [component]
+
+ self.bridges = {}
+ self.r_request = {}
+ self.s_request = {}
+ self._r_types = {}
+ self._s_types = {}
+ for v in self.variables:
+ self._r_types[v] = {}
+ self._s_types[v] = {}
+ self._toHost_fields = []
+ self._toDevice_fields = []
+ self._parent_rank = self.parent_comm.Get_rank()
+ self._my_rank = None
+
+ def discretize(self):
+
+ for v in self.variables:
+ if self.topology is None:
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ self.topology = self.opFrom.discreteFields[v].topology
+ else:
+ self.topology = self.opTo.discreteFields[v].topology
+
+ self._my_rank = self.topology.comm.Get_rank()
+ self._dim = self.topology.domain.dimension
+
+ for v in self.variables:
+ self.discreteFields[v] = v.discretize(self.topology)
+
+ @debug
+ def setUp(self):
+ """
+ Computes intersection of topologies and set the MPI intercommunicator.
+ """
+ assert self.topology.isUpToDate, \
+ """You should setup topology
+ before any attempt to setup a redistribute operator."""
+
+ # Look for an operator opertating on device.
+ try:
+ opFrom_is_device = \
+ self.opFrom.method[Support].find('gpu') >= 0
+ except KeyError: # op.method is a dict not containing Support in keys
+ opFrom_is_device = False
+ except IndexError: # op.method is a sting
+ opFrom_is_device = False
+ except TypeError: # op.method is None
+ opFrom_is_device = False
+ try:
+ opTo_is_device = \
+ self.opTo.method[Support].find('gpu') >= 0
+ except KeyError: # op.method is a dict not containing Support in keys
+ opTo_is_device = False
+ except IndexError: # op.method is a sting
+ opTo_is_device = False
+ except TypeError: # op.method is None
+ opTo_is_device = False
+
+ if not opFrom_is_device and not opTo_is_device:
+ # case: opFrom(host) --bridge--> opTo(host)
+ self._the_apply = self._apply_host
+ else:
+ # Have on device operators
+ if opFrom_is_device and not opTo_is_device:
+ # case: opFrom(GPU) --toHost--bridge--> opTo(host)
+ self._the_apply = self._apply_toHost_host
+ elif not opFrom_is_device and opTo_is_device:
+ # case: opFrom(host) --bridge--toDevice--> opTo(GPU)
+ self._the_apply = self._apply_host_toDevice
+ else:
+ # case: opFrom(GPU) --toHost--bridge--toDevice--> opTo(host)
+ # Transfers are removed if variables are batched
+ if np.any([self.opFrom.discreteFields[v].isBatch
+ for v in self.variables] +
+ [self.opTo.discreteFields[v].isBatch
+ for v in self.variables]):
+ self._the_apply = self._host
+ else:
+ self._the_apply = self._apply_toHost_host_toDevice
+
+ # Build bridges and toTransfer lists
+ self.bridge = Bridge_intercomm(self.topology, self.parent_comm,
+ self.id_from, self.id_to,
+ self.proc_tasks)
+
+ for v in self.variables:
+ # toTransfer list completion
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ if opFrom_is_device:
+ self._toHost_fields.append(self.opFrom.discreteFields[v])
+ if self.proc_tasks[self._parent_rank] == self.id_to:
+ if opTo_is_device:
+ self._toDevice_fields.append(self.opTo.discreteFields[v])
+
+ for v in self.variables:
+ dv = v.discreteFields[self.topology]
+ transfers = self.bridge.transfers
+ # Set reception
+ if self.proc_tasks[self._parent_rank] == self.id_to:
+ for from_rk in transfers.keys():
+ subshape = tuple(
+ [transfers[from_rk][i][1] - transfers[from_rk][i][0]
+ for i in range(self._dim)])
+ substart = tuple(
+ [transfers[from_rk][i][0] for i in range(self._dim)])
+ self._r_types[v][from_rk] = \
+ PARMES_MPI_REAL.Create_subarray(dv.data[0].shape,
+ subshape,
+ substart,
+ order=ORDERMPI)
+ self._r_types[v][from_rk].Commit()
+ # Set Sending
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ for to_rk in transfers.keys():
+ subshape = tuple(
+ [transfers[to_rk][i][1] - transfers[to_rk][i][0]
+ for i in range(self._dim)])
+ substart = tuple(
+ [transfers[to_rk][i][0] for i in range(self._dim)])
+ self._r_types[v][to_rk] = \
+ PARMES_MPI_REAL.Create_subarray(dv.data[0].shape,
+ subshape,
+ substart,
+ order=ORDERMPI)
+ self._r_types[v][to_rk].Commit()
+ self._isUpToDate = True
+
+ @debug
+ def apply(self, simulation=None):
+ """
+ Apply this operator to its variables.
+ @param simulation : object that describes the simulation
+ parameters (time, time step, iteration number ...), see
+ parmepy.problem.simulation.Simulation for details.
+ """
+ for req in self.requirements:
+ req.wait()
+ self._the_apply(simulation)
+
+ def _apply_toHost_host_toDevice(self, simulation=None):
+ if __VERBOSE__:
+ print ("{0} APPLY toHOST+HOST+toDEVICE".format(self._parent_rank))
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ self._toHost()
+ self._wait_device()
+ self._host()
+ self._wait_host()
+ if self.proc_tasks[self._parent_rank] == self.id_to:
+ self._toDevice()
+ self._wait_device()
+
+ def _apply_toHost_host(self, simulation=None):
+
+ if __VERBOSE__:
+ print ("{0} APPLY toHOST+HOST".format(self._parent_rank))
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ self._toHost()
+ self._wait_device()
+ self._host()
+ self._wait_host()
+
+ def _apply_host_toDevice(self, simulation=None):
+ if __VERBOSE__:
+ print ("{0} APPLY HOST+toDEVICE".format(self._parent_rank))
+ self._host()
+ self._wait_host()
+ self.parent_comm.Barrier()
+ if self.proc_tasks[self._parent_rank] == self.id_to:
+ self._toDevice()
+ self._wait_device()
+ self.parent_comm.Barrier()
+
+ def _apply_host(self, simulation=None):
+ if __VERBOSE__:
+ print ("{0} APPLY HOST".format(self._parent_rank))
+ self._host()
+ self._wait_host()
+
+ def _host(self, simulation=None):
+ """
+ Proceed with data redistribution from opFrom to opTo
+ """
+ self.parent_comm.Barrier()
+ self.r_request = {}
+ self.s_request = {}
+ for v in self.variables:
+ dv = v.discreteFields[self.topology]
+ transfers = self.bridge.transfers
+ for d in self._range_components(v):
+ v_name = dv.name + S_DIR[d]
+ # Set reception
+ if self.proc_tasks[self._parent_rank] == self.id_to:
+ for from_rk in transfers.keys():
+ self.r_request[v_name + str(from_rk)] = \
+ self.bridge.inter_comm.Irecv(
+ [dv.data[d], 1, self._r_types[v][from_rk]],
+ source=from_rk, tag=from_rk)
+ # Set Sending
+ if self.proc_tasks[self._parent_rank] == self.id_from:
+ for to_rk in transfers.keys():
+ self.s_request[v_name + str(to_rk)] = \
+ self.bridge.inter_comm.Issend(
+ [dv.data[d], 1, self._r_types[v][to_rk]],
+ dest=to_rk, tag=self._my_rank)
+
+ def _toHost(self):
+ """
+ Proceed with data transfer of variables from device to host
+ """
+ if __VERBOSE__:
+ print ("{0} APPLY toHOST".format(self._parent_rank))
+ for v in self.variables:
+ dv = self.opFrom.discreteFields[v]
+ if dv in self._toHost_fields:
+ dv.toHost(self.component)
+
+ def _toDevice(self):
+ """
+ Proceed with data transfer of variables from device to host
+ """
+ if __VERBOSE__:
+ print ("{0} APPLY toDEVICE".format(self._parent_rank))
+ for v in self.variables:
+ dv = self.opTo.discreteFields[v]
+ if dv in self._toDevice_fields:
+ dv.toDevice(self.component)
+
+ def _wait_device(self):
+ if __VERBOSE__:
+ print ("{0} WAIT OPENCL".format(self._parent_rank))
+ for dv in self._toDevice_fields + self._toHost_fields:
+ dv.wait()
+
+ def _wait_host(self, simulation=None):
+ """Wait for requests completion."""
+ if __VERBOSE__:
+ print ("{0} WAIT MPI".format(self._parent_rank))
+ for rk in self.r_request:
+ self.r_request[rk].Wait()
+ for rk in self.s_request:
+ self.s_request[rk].Wait()
+ self.parent_comm.Barrier()
+ self.r_request = []
+ self.s_request = []
+
+ def test(self, rsend=None, rrecv=None):
+ """
+ if neither rsend or rrecv is given return
+ True if all communication request are complete
+ else check for sending to rsend or
+ receiving from rrecv. Process ranks
+ should be given in local communicator.
+ @param rsend : variable name + S_DIR + rank
+ @param rrecv : variable name + S_DIR + rank
+ """
+ if(rsend is not None or rrecv is not None):
+ send_res = True
+ recv_res = True
+ if rsend is not None:
+ send_res = self.s_request[rsend].Test()
+ if rrecv is not None:
+ recv_res = self.r_request[rrecv].Test()
+ res = send_res and recv_res
+ else:
+ res = True
+ for rk in self.r_request.keys():
+ res = self.r_request[rk].Test()
+ if not res:
+ return res
+ for rk in self.s_request.keys():
+ res = self.s_request[rk].Test()
+ if not res:
+ return res
+ return res
diff --git a/HySoP/hysop/test/__init__.py b/HySoP/hysop/test/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/hysop/test/main_unit_tests.py b/HySoP/hysop/test/main_unit_tests.py
new file mode 100644
index 0000000000000000000000000000000000000000..7837dff17102b01da61363a2d86b3495ddc74125
--- /dev/null
+++ b/HySoP/hysop/test/main_unit_tests.py
@@ -0,0 +1,32 @@
+"""
+Launch tests for parmepy
+"""
+import unittest
+import doctest
+import sys
+import os
+# Insert parmepy sources path to sys.path from sys.path[0] (i.e. absolute path to __file__)
+# This file is desined to be launched after calling: setup.py build
+# Then this file is located in ./build/lib._platform_dependent_directory/parmepy/test
+# Tests are run on parmepy sources located in ./build/lib._platform_dependent_directory
+if sys.path[0].find("build/lib.") >= 0:
+ sys.path.insert(1, os.path.split(os.path.split(sys.path[0])[0])[0])
+import parmepy
+
+# Automatic recursive finding unittest.TestCase implemetations in package 'test'
+suite = unittest.TestLoader().discover(sys.path[0], pattern='test*.py')
+
+# Add doctests from python files
+suite.addTest(doctest.DocFileSuite('domain/box.py', package=parmepy))
+
+runner = unittest.TextTestRunner(verbosity=2).run(suite)
+
+if sys.path[0].find("build/lib.") >= 0:
+ if not runner.wasSuccessful():
+ fails = "\nFAILURES in " + __file__ + " : (" + str(len(runner.failures)) + ")\n"
+ for fail in runner.failures:
+ fails += fail[1]
+ log_failures = open('Testing/Temporary/PythonFailures.log', 'w')
+ log_failures.write(fails)
+ log_failures.close()
+ raise Exception("FAILED")
diff --git a/HySoP/hysop/test/test_obstacle/__init__.py b/HySoP/hysop/test/test_obstacle/__init__.py
new file mode 100755
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/hysop/test/test_obstacle/test_obstacle.py b/HySoP/hysop/test/test_obstacle/test_obstacle.py
new file mode 100644
index 0000000000000000000000000000000000000000..7154dac267e4e6942565cd4776e607eec318dc3b
--- /dev/null
+++ b/HySoP/hysop/test/test_obstacle/test_obstacle.py
@@ -0,0 +1,70 @@
+# -*- coding: utf-8 -*-
+import unittest
+import time
+import parmepy as pp
+import numpy as np
+import numpy.testing as npt
+from parmepy.constants import *
+from math import *
+
+
+
+def run():
+ # Parameters
+ nb = 65
+ timeStep = 0.02
+ finalTime = 1.
+# outputFilePrefix = './parmepy/test/test_obstacle/Domain_'
+ outputFilePrefix = './res/Domain_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Obstacle
+ sphere = pp.Obstacle(box, name='sphere', zlayer=0.1, radius=0.2, center=[0.5,0.5,0.5], orientation='West', porousLayer=0.1)
+
+ ## ChiDomain
+ chiDomain = pp.ContinuousField(domain=box, name='ChiDomain', vector=False)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3, periods = [False, False, False])
+
+ ## Obstacle discretization
+ chiDomain.discretize(topo3D)
+ chiDomainD = chiDomain.discreteField[0]
+ sphere.discretize(topo3D)
+ sphereD = sphere.discreteObstacle[0]
+ sphereD.chiFunctions()
+ for x in sphereD.chiBoundary[:] :
+ chiDomainD[x[0], x[1], x[2]]=1.
+ for x in sphereD.chiSolid[:] :
+ chiDomainD[x[0], x[1], x[2]]=1.
+ for x in sphereD.chiPorous[:] :
+ chiDomainD[x[0], x[1], x[2]]=0.5
+# for k in xrange (topo3D.mesh.resolution[2]):
+# for j in xrange (topo3D.mesh.resolution[2]):
+# for i in xrange (topo3D.mesh.resolution[2]):
+# if ([i,j,k] in sphereD.chiBoundary) :
+# chiDomainD[i,j,k]=1.
+# if ([i,j,k] in sphereD.chiSolid) :
+# chiDomainD[i,j,k]=1.
+# if ([i,j,k] in sphereD.chiPorous) :
+# chiDomainD[i,j,k]=0.5
+ io=pp.Printer(fields=[chiDomain], frequency=outputModulo, outputPrefix=outputFilePrefix)
+ io.step()
+
+ t1 = time.time()
+
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/HySoP/hysop/test/test_operator/__init__.py b/HySoP/hysop/test/test_operator/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/hysop/test/test_operator/test_CondStability.py b/HySoP/hysop/test/test_operator/test_CondStability.py
new file mode 100755
index 0000000000000000000000000000000000000000..e8b0c1271fdb30b1a86427d0fbd657a811411618
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_CondStability.py
@@ -0,0 +1,145 @@
+# -*- coding: utf-8 -*-
+import time
+from parmepy.operator.differentialOperator_d import DifferentialOperator_d
+from parmepy.particular_solvers.integrator.euler import Euler
+#from parmepy.particular_solvers.integrator.runge_kutta2 import RK2
+#from parmepy.particular_solvers.integrator.runge_kutta3 import RK3
+#from parmepy.particular_solvers.integrator.runge_kutta4 import RK4
+import parmepy as pp
+from parmepy.constants import *
+import numpy as np
+from math import *
+import unittest
+#import sys
+import struct
+import array
+
+
+class test_CondStability(unittest.TestCase):
+ """
+ Condition Stability test class
+ """
+
+ def vitesse(self,x, y, z):
+ vx = 1.
+ vy = 1.
+ vz = 1.
+ return vx, vy, vz
+
+ def vorticite(self,x, y, z):
+ wx = 1.
+ wy = 1.
+ wz = 1.
+ return wx, wy, wz
+
+ def scalaire(self,x, y, z):
+ if x < 0.5 and y < 0.5 and z < 0.5:
+ return 1.
+ else:
+ return 0.
+
+
+ def testCondStab(self):
+ # Parameters
+ nb = 128
+ timeStep = 0.09
+ finalTime = 0.09
+ self.t = 0.
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Fields
+ velo = pp.AnalyticalField(domain=box, formula=self.vitesse, name='Velocity', vector=True)
+ vorti = pp.AnalyticalField(domain=box, formula=self.vorticite, name='Vorticity', vector=True)
+
+ inputJBField = [np.zeros((nb,nb,nb), dtype=PARMES_REAL, order=ORDER) for d in xrange(3)]
+
+ f1 = open('./parmepy/test/data/Fields_sav0_U.data','rb')
+ f2 = open('./parmepy/test/data/Fields_sav0_V.data','rb')
+ f3 = open('./parmepy/test/data/Fields_sav0_W.data','rb')
+
+ nbx = np.asarray(struct.unpack("i",f1.read(4)))
+ nby = np.asarray(struct.unpack("i",f1.read(4)))
+ nbz = np.asarray(struct.unpack("i",f1.read(4)))
+
+ binvalues = array.array('d')
+ binvalues.read(f1, nbx*nby*nbz)
+
+ data = np.array(binvalues, dtype=PARMES_REAL)
+ inputJBField[0] = np.reshape(data, (nbx,nby,nbz))
+ f1.close()
+
+ nbx = np.asarray(struct.unpack("i",f2.read(4)))
+ nby = np.asarray(struct.unpack("i",f2.read(4)))
+ nbz = np.asarray(struct.unpack("i",f2.read(4)))
+
+ binvalues = array.array('d')
+ binvalues.read(f2, nbx*nby*nbz)
+
+ data = np.array(binvalues, dtype=PARMES_REAL)
+ inputJBField[1] = np.reshape(data, (nbx,nby,nbz))
+ f2.close()
+
+ nbx = np.asarray(struct.unpack("i",f3.read(4)))
+ nby = np.asarray(struct.unpack("i",f3.read(4)))
+ nbz = np.asarray(struct.unpack("i",f3.read(4)))
+
+ binvalues = array.array('d')
+ binvalues.read(f3, nbx*nby*nbz)
+
+ data = np.array(binvalues, dtype=PARMES_REAL)
+ inputJBField[2] = np.reshape(data, (nbx,nby,nbz))
+ f3.close()
+
+ ## Operators
+ stretch = pp.Stretching(velo,vorti)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nbx[0]+1, nby[0]+1, nbz[0]+1], dim=3, ghosts=[2,2,2])
+
+ ##Problem
+ pb = pp.Problem(topo3D, [stretch])
+
+ ## Setting solver to Problem
+ pb.setSolver(finalTime, timeStep, solver_type='basic')
+ pb.solver.ODESolver= Euler#RK4# RK3# RK2#
+ pb.initSolver()
+
+
+# self.result = [np.ones((nbx, nby, nbz), dtype=PARMES_REAL, order=ORDER) for d in xrange(3)]
+# vortidata= [np.zeros((128,128,128), dtype=PARMES_REAL, order=ORDER) for d in xrange(3)]
+ ## Input of JB velocity Fields
+# print 'shape', stretch.velocity.discreteField[0].data[1][2:nb+2, 2:nb+2,2:nb+2].shape ,inputJBField[1].shape
+ stretch.velocity.discreteField[0].data[0][2:nb+2,2:nb+2,2:nb+2] = inputJBField[0]
+ stretch.velocity.discreteField[0].data[1][2:nb+2,2:nb+2,2:nb+2] = inputJBField[1]
+ stretch.velocity.discreteField[0].data[2][2:nb+2,2:nb+2,2:nb+2] = inputJBField[2]
+# print 'shape', np.asarray(stretch.velocity.discreteField[0].data).shape
+
+ ## Calculation of vorticity Fields from velocity input data (JB)
+ self.curl = DifferentialOperator_d(stretch.velocity.discreteField[0].data, stretch.velocity.discreteField[0].data, choice='curl', topology=topo3D)
+ stretch.vorticity.discreteField[0].data = self.curl.discreteOperator.apply()
+ t1 = time.time()
+
+ ## Solve problem to deduce the LCFL
+ pb.solve()
+
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testCondStab()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_CondStability))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_Curl.py b/HySoP/hysop/test/test_operator/test_Curl.py
new file mode 100755
index 0000000000000000000000000000000000000000..db99cda641e56d900bcae083d837562ca8269bdb
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_Curl.py
@@ -0,0 +1,122 @@
+# -*- coding: utf-8 -*-
+import unittest
+
+#import parmepy
+
+from parmepy.operator.transport import *
+from parmepy.operator.continuous import *
+from parmepy.operator.differentialOperator import *
+from parmepy.operator.stretching import *
+from parmepy.fields.discrete import *
+from parmepy.fields.continuous import *
+from parmepy.fields.analytical import *
+from parmepy.domain.topology import *
+from parmepy.domain.box import *
+from parmepy.constants import *
+from parmepy.particular_solvers.basic import *
+from parmepy.particular_solvers.integrator.euler import *
+from parmepy.particular_solvers.solver import *
+import numpy as np
+import numpy.testing as npt
+import math
+
+
+class test_Curl(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+ def setUp(self):
+ self.e = 0.0001 # Accepted error between result and analytical result
+ self.dim = 3
+ self.boxLength = [2.*np.pi, 2.*np.pi, 2.*np.pi]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [33, 33, 33]
+ self.t = 0.
+ self.timeStep = 0.02
+ self.box = Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+
+ def testOperatorCurl(self):
+ # Continuous fields and operator declaration
+ self.velo = AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+ self.curl = DifferentialOperator(self.velo, self.velo, choice='curl')
+ # Topology definition
+ self.topo3D = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[2,2,2])
+ self.topo3DnoG = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[0,0,0])
+ self.result = [np.ones((self.topo3D.mesh.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ # Fields and operator discretization
+ self.velo.discretize(self.topo3D)
+ self.velo.initialize()
+ self.curl.discretize(self.velo.discreteField[self.velo._fieldId], self.velo.discreteField[self.velo._fieldId], topology=self.topo3D)
+ self.result = self.curl.discreteOperator.apply()
+ self.FinalTime = 0.02
+ self.anal = np.vectorize(self.vorticite)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+ # Comparison with analytical solution
+# print "max:",np.max(abs(self.anal[0]-self.result[0]))
+ ind0a = self.topo3D.ghosts[0]
+ ind0b = self.topo3D.mesh.resolution[0]-self.topo3D.ghosts[0]
+ ind1a = self.topo3D.ghosts[1]
+ ind1b = self.topo3D.mesh.resolution[1]-self.topo3D.ghosts[1]
+ ind2a = self.topo3D.ghosts[2]
+ ind2b = self.topo3D.mesh.resolution[2]-self.topo3D.ghosts[2]
+ npt.assert_array_less(abs(self.anal[0] - \
+ self.result[0][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[1]-self.result[1]))
+ npt.assert_array_less(abs(self.anal[1] - \
+ self.result[1][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[2]-self.result[2]))
+ npt.assert_array_less(abs(self.anal[2] - \
+ self.result[2][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+
+ def vitesse(self, x, y, z):
+# amodul = np.cos(np.pi*self.t/3)
+# pix = np.pi*x
+# piy = np.pi*y
+# piz = np.pi*z
+# pi2x = 2.*pix
+# pi2y = 2.*piy
+# pi2z = 2.*piz
+# vx = 2.*np.sin(pix)*np.sin(pix)*np.sin(pi2y)*np.sin(pi2z)*amodul
+# vy = -np.sin(pi2x)*np.sin(piy)*np.sin(piy)*np.sin(pi2z)*amodul
+# vz = -np.sin(pi2x)*np.sin(piz)*np.sin(piz)*np.sin(pi2y)*amodul
+# vx = np.cos(y)
+# vy = np.cos(z)
+# vz = np.cos(x)
+ vx = np.cos(y) * np.cos(z)
+ vy = np.cos(z) * np.cos(x)
+ vz = np.cos(x) * np.cos(y)
+ return vx, vy, vz
+
+ def vorticite(self, x, y, z):
+# amodul = np.cos(np.pi*self.t/3)
+# pix = np.pi*x
+# piy = np.pi*y
+# piz = np.pi*z
+# pi2x = 2.*pix
+# pi2y = 2.*piy
+# pi2z = 2.*piz
+# wx = 2.* np.pi * np.sin(pi2x) * amodul*( - np.cos(pi2y)*np.sin(piz)*np.sin(piz)+ np.sin(piy)*np.sin(piy)*np.cos(pi2z) )
+# wy = 2.* np.pi * np.sin(pi2y) * amodul*( 2.*np.cos(pi2z)*np.sin(pix)*np.sin(pix)+ np.sin(piz)*np.sin(piz)*np.cos(pi2x) )
+# wz = -2.* np.pi * np.sin(pi2z) * amodul*( np.cos(pi2x)*np.sin(piy)*np.sin(piy)+ np.sin(pix)*np.sin(pix)*np.cos(pi2y) )
+# wx = np.sin(z)
+# wy = np.sin(x)
+# wz = np.sin(y)
+ wx = np.cos(x) * (np.sin(z) - np.sin(y))
+ wy = np.cos(y) * (np.sin(x) - np.sin(z))
+ wz = np.cos(z) * (np.sin(y) - np.sin(x))
+ return wx, wy, wz
+
+ def runTest(self):
+ self.setUp()
+ self.testOperatorCurl()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Curl))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_DivProduct.py b/HySoP/hysop/test/test_operator/test_DivProduct.py
new file mode 100755
index 0000000000000000000000000000000000000000..0a5abf49a9c51953bf1db1835f7f2c8cc3470459
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_DivProduct.py
@@ -0,0 +1,109 @@
+# -*- coding: utf-8 -*-
+import unittest
+
+#import parmepy
+
+from parmepy.operator.transport import *
+from parmepy.operator.continuous import *
+from parmepy.operator.differentialOperator import *
+from parmepy.operator.stretching import *
+from parmepy.fields.discrete import *
+from parmepy.fields.continuous import *
+from parmepy.fields.analytical import *
+from parmepy.domain.topology import *
+from parmepy.domain.box import *
+from parmepy.constants import *
+from parmepy.particular_solvers.basic import *
+from parmepy.particular_solvers.integrator.euler import *
+from parmepy.particular_solvers.solver import *
+import numpy as np
+import numpy.testing as npt
+import math
+
+
+class test_DivProduct(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+ def setUp(self):
+ self.e = 0.0002 # Accepted error between result and analytical result
+ self.dim = 3
+ self.boxLength = [2.*np.pi, 2.*np.pi, 2.*np.pi]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [32, 32, 32]
+ self.timeStep = 0.02
+ self.ghosts = [2,2,2]
+ self.box = Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+
+ def testOperatorDiv(self):
+ # Continuous fields and operator declaration
+ self.velo = AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+ self.vorti = AnalyticalField(domain=self.box, formula=self.vorticite, name='Vorticity', vector=True)
+ # chercher cas test de tel sorte que le stretching serait periodique et analytique
+ self.div = DifferentialOperator(self.vorti, self.velo, choice='divWU')
+ # Topology definition / Fields and operator discretization
+# self.result = [np.ones((self.nbPts), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ self.topo3D = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=self.ghosts)
+ self.topo3DnoG = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[0,0,0])
+ self.vorti.discretize(self.topo3D)
+ self.velo.discretize(self.topo3D)
+ self.vorti.initialize()
+ self.velo.initialize()
+# print 'size velo', self.velo.discreteField[self.velo._fieldId]
+ self.div.discretize(self.vorti.discreteField[self.vorti._fieldId], self.velo.discreteField[self.velo._fieldId], topology=self.topo3D)
+ self.result = self.div.discreteOperator.apply()
+ self.resol = self.topo3D.mesh.resolution
+ self.FinalTime = 0.2
+ self.anal=np.vectorize(self.analyticalDivProduct)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+ # Comparison with analytical solution
+# npt.assert_array_less(abs(self.anal[0][self.ghosts[0]:self.nbPts[0]+self.ghosts[0],\
+# self.ghosts[1]:self.nbPts[1]+self.ghosts[1],\
+# self.ghosts[2]:self.nbPts[2]+self.ghosts[2]]-self.result[0]), self.e)
+# npt.assert_array_less(abs(self.anal[1][self.ghosts[0]:self.nbPts[0]+self.ghosts[0],\
+# self.ghosts[1]:self.nbPts[1]+self.ghosts[1],\
+# self.ghosts[2]:self.nbPts[2]+self.ghosts[2]]-self.result[1]), self.e)
+# npt.assert_array_less(abs(self.anal[2][self.ghosts[0]:self.nbPts[0]+self.ghosts[0],\
+# self.ghosts[1]:self.nbPts[1]+self.ghosts[1],\
+# self.ghosts[2]:self.nbPts[2]+self.ghosts[2]]-self.result[2]), self.e)
+# print "max:",np.max(abs(self.anal[2][self.ghosts[0]:self.nbPts[0]+self.ghosts[0],\
+# self.ghosts[1]:self.nbPts[1]+self.ghosts[1],\
+# self.ghosts[2]:self.nbPts[2]+self.ghosts[2]]-self.result[2]))
+
+ npt.assert_array_less(abs(self.anal[0]-self.result[0]), self.e)
+ npt.assert_array_less(abs(self.anal[1]-self.result[1]), self.e)
+ npt.assert_array_less(abs(self.anal[2]-self.result[2]), self.e)
+ print "max:",np.max(abs(self.anal[2]-self.result[2]))
+
+ def vitesse(self, x, y, z):
+ vx = np.sin(x)
+ vy = np.sin(y)
+ vz = np.sin(z)
+ return vx, vy, vz
+
+ def vorticite(self, x, y, z):
+ wx = 1.
+ wy = 1.
+ wz = 1.
+ return wx, wy, wz
+
+ def analyticalDivProduct(self, x, y, z):
+ sx = np.cos(x)
+ sy = np.cos(y)
+ sz = np.cos(z)
+ return sx, sy, sz
+
+ def runTest(self):
+ self.setUp()
+ self.testOperatorDiv()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_DivProduct))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_Forces.py b/HySoP/hysop/test/test_operator/test_Forces.py
new file mode 100755
index 0000000000000000000000000000000000000000..ae5f758e667570be47ad2f9380c3ea2e9c8f5c4b
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_Forces.py
@@ -0,0 +1,120 @@
+# -*- coding: utf-8 -*-
+import time
+from parmepy.physics.compute_forces import Compute_forces
+import parmepy as pp
+import numpy as np
+from math import *
+import unittest
+
+
+
+class test_Forces(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+
+ def vitesse(self,x, y, z):
+# vx = 1. + x
+# vy = - x * y
+# vz = x * y * z + 10.
+ amodul = np.cos(np.pi*self.t/3)
+ pix = np.pi*x
+ piy = np.pi*y
+ piz = np.pi*z
+ pi2x = 2.*pix
+ pi2y = 2.*piy
+ pi2z = 2.*piz
+ vx = 2.*np.sin(pix)*np.sin(pix)*np.sin(pi2y)*np.sin(pi2z)*amodul
+ vy = -np.sin(pi2x)*np.sin(piy)*np.sin(piy)*np.sin(pi2z)*amodul
+ vz = -np.sin(pi2x)*np.sin(piz)*np.sin(piz)*np.sin(pi2y)*amodul
+ return vx, vy, vz
+
+ def vorticite(self,x, y, z):
+# wx = x * y
+# wy = y * z
+# wz = - y
+ amodul = np.cos(np.pi*self.t/3)
+ pix = np.pi*x
+ piy = np.pi*y
+ piz = np.pi*z
+ pi2x = 2.*pix
+ pi2y = 2.*piy
+ pi2z = 2.*piz
+ wx = 2.* np.pi * np.sin(pi2x) * amodul*( - np.cos(pi2y)*np.sin(piz)*np.sin(piz)+ np.sin(piy)*np.sin(piy)*np.cos(pi2z) )
+ wy = 2.* np.pi * np.sin(pi2y) * amodul*( 2.*np.cos(pi2z)*np.sin(pix)*np.sin(pix)+ np.sin(piz)*np.sin(piz)*np.cos(pi2x) )
+ wz = -2.* np.pi * np.sin(pi2z) * amodul*( np.cos(pi2x)*np.sin(piy)*np.sin(piy)+ np.sin(pix)*np.sin(pix)*np.cos(pi2y) )
+ return wx, wy, wz
+
+ def scalaire(self,x, y, z):
+ if x < 0.5 and y < 0.5 and z < 0.5:
+ return 1.
+ else:
+ return 0.
+
+
+ def testComputeForces(self):
+ # Parameters
+ nb = 11
+ timeStep = 0.09
+ finalTime = 0.36
+ self.t = 0.
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Obstacle
+ sphere = pp.Obstacle(box, zlayer=0.1, radius=0.1,
+ center=[0.5, 0.5, 0.5], name='sphere',
+ orientation='West', porousLayer=0.05)
+
+ ## Fields
+ velo = pp.AnalyticalField(domain=box, formula=self.vitesse, name='Velocity', vector=True)
+ vorti = pp.AnalyticalField(domain=box, formula=self.vorticite, name='Vorticity', vector=True)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3, ghosts=[2,2,2])
+
+ ## Fields discretization
+ vorti.discretize(topo3D)
+ velo.discretize(topo3D)
+ vorti.initialize()
+ velo.initialize()
+
+ # Forces computation
+ Re = 200.
+ noca = Compute_forces(topo3D, sphere, boxMin= [0.2, 0.2, 0.2], boxMax=[0.8, 0.8, 0.8])
+ if (topo3D.rank == 0):
+ f = open('./parmepy/test/test_operator/NocaForces.dat', 'w')
+
+ while (self.t <= finalTime):
+ nocares = noca.apply(self.t, timeStep, velo.discreteField[velo._fieldId], vorti.discreteField[vorti._fieldId], Re)
+ if (topo3D.rank == 0):
+ # print time and forces values in the following order : time, cX, cY, cZ
+ f.write("%s %s %s %s\n" % (self.t, nocares[0], nocares[1], nocares[2]))
+
+
+ self.t = self.t + timeStep
+
+ if (topo3D.rank == 0):
+ f.close()
+
+ t1 = time.time()
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testComputeForces()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Forces))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_Grad.py b/HySoP/hysop/test/test_operator/test_Grad.py
new file mode 100755
index 0000000000000000000000000000000000000000..ac8364907e75e5069b9e9135a4c50aee0df387fc
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_Grad.py
@@ -0,0 +1,146 @@
+# -*- coding: utf-8 -*-
+import unittest
+
+#import parmepy
+
+from parmepy.operator.transport import *
+from parmepy.operator.continuous import *
+from parmepy.operator.differentialOperator import *
+from parmepy.operator.stretching import *
+from parmepy.fields.discrete import *
+from parmepy.fields.continuous import *
+from parmepy.fields.analytical import *
+from parmepy.domain.topology import *
+from parmepy.domain.box import *
+from parmepy.constants import *
+from parmepy.particular_solvers.basic import *
+from parmepy.particular_solvers.integrator.euler import *
+from parmepy.particular_solvers.solver import *
+import numpy as np
+import numpy.testing as npt
+import math
+
+
+class test_Grad(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+ def setUp(self):
+ self.e = 0.0001 # Accepted error between numerical and analytical results
+ self.dim = 3
+ self.boxLength = [2.*np.pi, 2.*np.pi, 2.*np.pi]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [33, 33, 33]
+ self.t = 0.
+ self.timeStep = 0.02
+ self.box = Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+
+ def testOperatorGrad(self):
+ # Continuous fields and operator declaration
+ self.velo = AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+ self.grad = DifferentialOperator(self.velo, self.velo, choice='gradV')
+ # Topology definition
+ self.topo3D = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[2,2,2])
+ self.topo3DnoG = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[0,0,0])
+ self.result = [np.ones((self.topo3D.mesh.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim * self.dim)]
+ # Fields and operator discretization
+ self.velo.discretize(self.topo3D)
+ self.velo.initialize()
+ self.grad.discretize(self.velo.discreteField[self.velo._fieldId], self.velo.discreteField[self.velo._fieldId], topology=self.topo3D)
+ self.result, maxgersh = self.grad.discreteOperator.apply()
+ self.FinalTime = 0.02
+ self.analX = np.vectorize(self.gradientUx)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+ self.analY = np.vectorize(self.gradientUy)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+ self.analZ = np.vectorize(self.gradientUz)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+ # Comparison with analytical solution
+# print "max:",np.max(abs(self.anal[0]-self.result[0]))
+ ind0a = self.topo3D.ghosts[0]
+ ind0b = self.topo3D.mesh.resolution[0]-self.topo3D.ghosts[0]
+ ind1a = self.topo3D.ghosts[1]
+ ind1b = self.topo3D.mesh.resolution[1]-self.topo3D.ghosts[1]
+ ind2a = self.topo3D.ghosts[2]
+ ind2b = self.topo3D.mesh.resolution[2]-self.topo3D.ghosts[2]
+
+ npt.assert_array_less(abs(self.analX[0] - \
+ self.result[0][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[1]-self.result[1]))
+ npt.assert_array_less(abs(self.analX[1] - \
+ self.result[1][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[2]-self.result[2]))
+ npt.assert_array_less(abs(self.analX[2] - \
+ self.result[2][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+
+ npt.assert_array_less(abs(self.analY[0] - \
+ self.result[3][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[1]-self.result[1]))
+ npt.assert_array_less(abs(self.analY[1] - \
+ self.result[4][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[2]-self.result[2]))
+ npt.assert_array_less(abs(self.analY[2] - \
+ self.result[5][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+
+ npt.assert_array_less(abs(self.analZ[0] - \
+ self.result[6][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[1]-self.result[1]))
+ npt.assert_array_less(abs(self.analZ[1] - \
+ self.result[7][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[2]-self.result[2]))
+ npt.assert_array_less(abs(self.analZ[2] - \
+ self.result[8][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+
+ def vitesse(self, x, y, z):
+# amodul = np.cos(np.pi*self.t/3)
+# pix = np.pi*x
+# piy = np.pi*y
+# piz = np.pi*z
+# pi2x = 2.*pix
+# pi2y = 2.*piy
+# pi2z = 2.*piz
+# vx = 2.*np.sin(pix)*np.sin(pix)*np.sin(pi2y)*np.sin(pi2z)*amodul
+# vy = -np.sin(pi2x)*np.sin(piy)*np.sin(piy)*np.sin(pi2z)*amodul
+# vz = -np.sin(pi2x)*np.sin(piz)*np.sin(piz)*np.sin(pi2y)*amodul
+# vx = np.cos(y)
+# vy = np.cos(z)
+# vz = np.cos(x)
+ vx = np.cos(y) * np.cos(z)
+ vy = np.cos(z) * np.cos(x)
+ vz = np.cos(x) * np.cos(y)
+ return vx, vy, vz
+
+ def gradientUx(self, x, y, z):
+ dUxdx = 0.
+ dUxdy = - np.sin(y) * np.cos(z)
+ dUxdz = - np.sin(z) * np.cos(y)
+ return dUxdx, dUxdy, dUxdz
+
+ def gradientUy(self, x, y, z):
+ dUydx = - np.sin(x) * np.cos(z)
+ dUydy = 0.
+ dUydz = - np.sin(z) * np.cos(x)
+ return dUydx, dUydy, dUydz
+
+ def gradientUz(self, x, y, z):
+ dUzdx = - np.sin(x) * np.cos(y)
+ dUzdy = - np.sin(y) * np.cos(x)
+ dUzdz = 0.
+ return dUzdx, dUzdy, dUzdz
+
+ def runTest(self):
+ self.setUp()
+ self.testOperatorGrad()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Grad))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_GradUomega.py b/HySoP/hysop/test/test_operator/test_GradUomega.py
new file mode 100755
index 0000000000000000000000000000000000000000..9ebccb53b0f0dc819d5bb963cd476025bf2ae9c1
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_GradUomega.py
@@ -0,0 +1,121 @@
+# -*- coding: utf-8 -*-
+import unittest
+
+#import parmepy
+
+from parmepy.operator.transport import *
+from parmepy.operator.continuous import *
+from parmepy.operator.differentialOperator import *
+from parmepy.operator.fct2op import *
+from parmepy.operator.stretching import *
+from parmepy.fields.discrete import *
+from parmepy.fields.continuous import *
+from parmepy.fields.analytical import *
+from parmepy.domain.topology import *
+from parmepy.domain.box import *
+from parmepy.constants import *
+from parmepy.particular_solvers.basic import *
+from parmepy.particular_solvers.integrator.euler import *
+from parmepy.particular_solvers.solver import *
+import numpy as np
+import numpy.testing as npt
+import math
+
+
+class test_GradUomega(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+ def setUp(self):
+ self.e = 0.0001 # Accepted error between numerical and analytical results
+ self.dim = 3
+ self.boxLength = [2.*np.pi, 2.*np.pi, 2.*np.pi]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [33, 33, 33]
+ self.t = 0.
+ self.timeStep = 0.02
+ self.box = Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+
+ def testOperatorGradUomega(self):
+ # Continuous fields and operator declaration
+ self.velo = AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+ self.curl = DifferentialOperator(self.velo, self.velo, choice='curl')
+ self.grad = DifferentialOperator(self.velo, self.velo, choice='gradV')
+ # Topology definition
+ self.topo3D = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[2,2,2])
+ self.topo3DnoG = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, ghosts=[0,0,0])
+ self.omega = [np.ones((self.topo3D.mesh.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ self.gradientU = [np.ones((self.topo3D.mesh.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim * self.dim)]
+ self.result = [np.ones((self.topo3D.mesh.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ # Fields and operator discretization
+ self.velo.discretize(self.topo3D)
+ self.velo.initialize()
+ self.curl.discretize(self.velo.discreteField[self.velo._fieldId], self.velo.discreteField[self.velo._fieldId], topology=self.topo3D)
+ self.grad.discretize(self.velo.discreteField[self.velo._fieldId], self.velo.discreteField[self.velo._fieldId], topology=self.topo3D)
+ self.omega = self.curl.discreteOperator.apply()
+ self.gradientU, maxgersh = self.grad.discreteOperator.apply()
+ self.gradUomega = Fct2Op(self.omega, self.gradientU, choice = 'gradV', topology=self.topo3D)
+ self.result = self.gradUomega.apply(self.t, self.omega)
+
+ self.FinalTime = 0.02
+ self.anal = np.vectorize(self.stretch)(self.topo3DnoG.mesh.coords[0], \
+ self.topo3DnoG.mesh.coords[1], \
+ self.topo3DnoG.mesh.coords[2])
+
+
+ # Comparison with analytical solution
+# print "max:",np.max(abs(self.anal[0]-self.result[0]))
+ ind0a = self.topo3D.ghosts[0]
+ ind0b = self.topo3D.mesh.resolution[0]-self.topo3D.ghosts[0]
+ ind1a = self.topo3D.ghosts[1]
+ ind1b = self.topo3D.mesh.resolution[1]-self.topo3D.ghosts[1]
+ ind2a = self.topo3D.ghosts[2]
+ ind2b = self.topo3D.mesh.resolution[2]-self.topo3D.ghosts[2]
+
+ npt.assert_array_less(abs(self.anal[0] - \
+ self.result[0][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[1]-self.result[1]))
+ npt.assert_array_less(abs(self.anal[1] - \
+ self.result[1][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+# print "max:",np.max(abs(self.anal[2]-self.result[2]))
+ npt.assert_array_less(abs(self.anal[2] - \
+ self.result[2][ind0a:ind0b,ind1a:ind1b,ind2a:ind2b]), self.e)
+
+ def vitesse(self, x, y, z):
+# amodul = np.cos(np.pi*self.t/3)
+# pix = np.pi*x
+# piy = np.pi*y
+# piz = np.pi*z
+# pi2x = 2.*pix
+# pi2y = 2.*piy
+# pi2z = 2.*piz
+# vx = 2.*np.sin(pix)*np.sin(pix)*np.sin(pi2y)*np.sin(pi2z)*amodul
+# vy = -np.sin(pi2x)*np.sin(piy)*np.sin(piy)*np.sin(pi2z)*amodul
+# vz = -np.sin(pi2x)*np.sin(piz)*np.sin(piz)*np.sin(pi2y)*amodul
+# vx = np.cos(y)
+# vy = np.cos(z)
+# vz = np.cos(x)
+ vx = np.cos(y) * np.cos(z)
+ vy = np.cos(z) * np.cos(x)
+ vz = np.cos(x) * np.cos(y)
+ return vx, vy, vz
+
+ def stretch(self, x, y, z):
+ sx = - np.cos(z) * np.cos(y) * ( np.sin(x) * np.sin(y) - np.sin(z) * np.sin(x))
+ sy = - np.cos(z) * np.cos(x) * ( - np.sin(x) * np.sin(y) + np.sin(z) * np.sin(y))
+ sz = - np.cos(y) * np.cos(x) * ( np.sin(x) * np.sin(z) - np.sin(y) * np.sin(z))
+ return sx, sy, sz
+
+ def runTest(self):
+ self.setUp()
+ self.testOperatorGrad()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_GradUomega))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_Penalization.py b/HySoP/hysop/test/test_operator/test_Penalization.py
new file mode 100644
index 0000000000000000000000000000000000000000..4f5529385a68804bfec3c260a08f6e5295333a77
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_Penalization.py
@@ -0,0 +1,76 @@
+# -*- coding: utf-8 -*-
+import unittest
+import time
+import parmepy as pp
+import numpy as np
+from parmepy.particular_solvers.integrator.runge_kutta4 import RK4
+import numpy.testing as npt
+from parmepy.constants import *
+from math import *
+
+def vitesse(x, y, z):
+ vx = 2.
+ vy = 2.
+ vz = 2.
+ return vx, vy, vz
+
+def vorticite(x, y, z):
+ wx = 3.
+ wy = 3.
+ wz = 3.
+ return wx, wy, wz
+
+
+def run():
+ # Parameters
+ nb = 129
+ timeStep = 0.09
+ finalTime = 0.09
+ outputFilePrefix = './parmepy/test/test_operator/Penalization_'
+ outputModulo = 1
+
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Obstacle
+ lambd=np.array([0, 10, 10**8],dtype = PARMES_REAL, order=ORDER)
+ sphere = pp.Obstacle(box, zlayer=0.1, radius=0.2, center=[0.5, 0.5, 0.5],
+ name='sphere', orientation='West', porousLayer=0.1)
+
+ ## ChiDomain
+ chiDomain = pp.ContinuousField(domain=box, name='ChiDomain', vector=False)
+
+ ## Fields
+ velo = pp.AnalyticalField(domain=box, formula=vitesse, name='Velocity', vector=True)
+ vorti = pp.AnalyticalField(domain=box, formula=vorticite, name='Vorticity', vector=True)
+
+ ## Operators
+ penal = pp.Penalization(velo, vorti, sphere, lambd)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3, ghosts=[2,2,2])
+
+ pb = pp.Problem(topo3D, [penal])
+
+ ## Setting solver to Problem
+ pb.setSolver(finalTime, timeStep, solver_type='basic', io=pp.Printer(fields=[velo, vorti], frequency=outputModulo, outputPrefix=outputFilePrefix))
+ pb.solver.ODESolver= RK4# RK3# RK2# Euler#
+ pb.initSolver()
+ t1 = time.time()
+
+ ## Solve problem
+ pb.solve()
+
+ tf = time.time()
+
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+if __name__ == "__main__":
+ run()
diff --git a/HySoP/hysop/test/test_operator/test_Stretching.py b/HySoP/hysop/test/test_operator/test_Stretching.py
new file mode 100755
index 0000000000000000000000000000000000000000..1ee8a2e576b769bf2975ec8f063cceb84b5a0a6b
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_Stretching.py
@@ -0,0 +1,109 @@
+# -*- coding: utf-8 -*-
+import time
+from parmepy.particular_solvers.integrator.euler import Euler
+from parmepy.particular_solvers.integrator.runge_kutta2 import RK2
+from parmepy.particular_solvers.integrator.runge_kutta3 import RK3
+from parmepy.particular_solvers.integrator.runge_kutta4 import RK4
+import parmepy as pp
+import numpy as np
+from math import *
+import unittest
+
+
+
+class test_Stretching(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+
+ def vitesse(self,x, y, z):
+# vx = 1. + x
+# vy = - x * y
+# vz = x * y * z + 10.
+ amodul = np.cos(np.pi*self.t/3)
+ pix = np.pi*x
+ piy = np.pi*y
+ piz = np.pi*z
+ pi2x = 2.*pix
+ pi2y = 2.*piy
+ pi2z = 2.*piz
+ vx = 2.*np.sin(pix)*np.sin(pix)*np.sin(pi2y)*np.sin(pi2z)*amodul
+ vy = -np.sin(pi2x)*np.sin(piy)*np.sin(piy)*np.sin(pi2z)*amodul
+ vz = -np.sin(pi2x)*np.sin(piz)*np.sin(piz)*np.sin(pi2y)*amodul
+ return vx, vy, vz
+
+ def vorticite(self,x, y, z):
+# wx = x * y
+# wy = y * z
+# wz = - y
+ amodul = np.cos(np.pi*self.t/3)
+ pix = np.pi*x
+ piy = np.pi*y
+ piz = np.pi*z
+ pi2x = 2.*pix
+ pi2y = 2.*piy
+ pi2z = 2.*piz
+ wx = 2.* np.pi * np.sin(pi2x) * amodul*( - np.cos(pi2y)*np.sin(piz)*np.sin(piz)+ np.sin(piy)*np.sin(piy)*np.cos(pi2z) )
+ wy = 2.* np.pi * np.sin(pi2y) * amodul*( 2.*np.cos(pi2z)*np.sin(pix)*np.sin(pix)+ np.sin(piz)*np.sin(piz)*np.cos(pi2x) )
+ wz = -2.* np.pi * np.sin(pi2z) * amodul*( np.cos(pi2x)*np.sin(piy)*np.sin(piy)+ np.sin(pix)*np.sin(pix)*np.cos(pi2y) )
+ return wx, wy, wz
+
+ def scalaire(self,x, y, z):
+ if x < 0.5 and y < 0.5 and z < 0.5:
+ return 1.
+ else:
+ return 0.
+
+
+ def testOperatorStretching(self):
+ # Parameters
+ nb = 16
+ timeStep = 0.09
+ finalTime = 0.09
+ self.t = 0.
+ t0 = time.time()
+
+ ## Domain
+ box = pp.Box(3, length=[1., 1., 1.], origin=[0., 0., 0.])
+
+ ## Fields
+ velo = pp.AnalyticalField(domain=box, formula=self.vitesse, name='Velocity', vector=True)
+ vorti = pp.AnalyticalField(domain=box, formula=self.vorticite, name='Vorticity', vector=True)
+
+ ## Operators
+ stretch = pp.Stretching(velo,vorti)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3, ghosts=[2.,2.,2.])
+
+ ##Problem
+ pb = pp.Problem(topo3D, [stretch])
+
+ ## Setting solver to Problem
+ pb.setSolver(finalTime, timeStep, solver_type='basic')
+ pb.solver.ODESolver= RK3#RK2#Euler#RK4#
+ pb.initSolver()
+
+ t1 = time.time()
+
+ ## Solve problem
+ pb.solve()
+
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testOperatorStretching()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Stretching))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_operator/test_transport_d.py b/HySoP/hysop/test/test_operator/test_transport_d.py
new file mode 100644
index 0000000000000000000000000000000000000000..14585b5f530890c796df347639377276a517ff59
--- /dev/null
+++ b/HySoP/hysop/test/test_operator/test_transport_d.py
@@ -0,0 +1,122 @@
+"""
+Module for testing parmepy.operator.transport_d
+"""
+
+import unittest
+import parmepy as pp
+import numpy as np
+import pyopencl as cl
+
+
+class Transport_dTestCase(unittest.TestCase):
+
+ def setUp_OpenCL_basic(self):
+ self.b = pp.Box()
+ self.nbElem = [32, 32, 32]
+ self.topo = pp.CartesianTopology(domain=self.b,
+ resolution=self.nbElem,
+ dim=len(self.nbElem))
+ build_options = "-cl-single-precision-constant -cl-opt-disable"
+ build_options += " -D WIDTH=32"
+ build_options += " -D WGN=32"
+ build_options += " -D PADDING=0"
+ build_options += " -D BASIC=1"
+ self.prg_basic = cl.Program(self.ctx, self.gpu_src).build(build_options)
+ self.p_positions = pp.fields.continuous.ContinuousField(self.b,
+ name="test_field_positions")
+ self.p_scalar = pp.fields.continuous.ContinuousField(self.b,
+ name="test_field_scalar")
+ self.true_p_positions = pp.fields.analytical.AnalyticalField(self.b,
+ formula=lambda x,y,z:x,
+ name="test_field_true_positions")
+ self.g_velocity = pp.fields.analytical.AnalyticalField(self.b,
+ formula=lambda x, y, z: (0., 1., 0.),
+ name="test_field_g_velocity", vector=True)
+ self.g_scalar = pp.fields.analytical.AnalyticalField(self.b,
+ formula=lambda x, y, z: 1.,
+ name="test_field_g_scalar")
+ self.b.discretize(self.topo.resolution)
+ self.pos, self.pos_id = self.p_positions.discretize(self.topo)
+ self.scal, self.velo_id = self.p_scalar.discretize(self.topo)
+ self.gvelo, self.pos_id = self.g_velocity.discretize(self.topo)
+ self.gscal, self.velo_id = self.g_scalar.discretize(self.topo)
+ self.true_pos, self.velo_id = self.true_p_positions.discretize(self.topo)
+ self.true_p_positions.initialize()
+ self.g_velocity.initialize()
+ self.g_scalar.initialize()
+ self.pos.data = np.asarray(self.pos.data, dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.scal.data = np.asarray(self.scal.data, dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.gvelo.data[0] = np.asarray(self.gvelo.data[0], dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.gvelo.data[1] = np.asarray(self.gvelo.data[1], dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.gvelo.data[2] = np.asarray(self.gvelo.data[2], dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.gscal.data = np.asarray(self.gscal.data, dtype=pp.constants.PARMES_REAL_GPU, order='F')
+ self.pos.gpu_data = cl.Buffer(self.ctx, cl.mem_flags.READ_WRITE,
+ size=self.pos.data.nbytes)
+ self.scal.gpu_data = cl.Buffer(self.ctx, cl.mem_flags.READ_WRITE,
+ size=self.scal.data.nbytes)
+ self.gvelo.gpu_data = [cl.Buffer(self.ctx, cl.mem_flags.READ_WRITE,
+ size=gvelo.nbytes) for gvelo in self.gvelo.data]
+ self.gscal.gpu_data = cl.Buffer(self.ctx, cl.mem_flags.READ_WRITE,
+ size=self.gscal.data.nbytes)
+ cl.enqueue_copy(self.queue, self.gscal.gpu_data, self.gscal.data)
+ cl.enqueue_copy(self.queue, self.gvelo.gpu_data[0], self.gvelo.data[0])
+ cl.enqueue_copy(self.queue, self.gvelo.gpu_data[1], self.gvelo.data[1])
+ cl.enqueue_copy(self.queue, self.gvelo.gpu_data[2], self.gvelo.data[2])
+ self.transport = pp.Transport(self.g_velocity, self.g_scalar)
+ self.transport.discretize(result_position=self.p_positions, result_scalar=self.p_scalar)
+ self.transport.setMethod(pp.particular_solvers.gpu.KernelLauncher(self.prg_basic.advection,
+ self.queue,
+ (32, 32, 32), None))
+ self.transport.discreteOperator.init_copy = pp.particular_solvers.gpu.KernelLauncher(self.prg_basic.advec_init_copy,
+ self.queue,
+ (32, 32, 32), None)
+ self.transport.discreteOperator.init_transpose = pp.particular_solvers.gpu.KernelListLauncher([self.prg_basic.advec_init_transpose_3D_01,
+ self.prg_basic.advec_init_transpose_3D_02],
+ self.queue,
+ [(2 * int(self.nbElem[0]),
+ int(self.nbElem[1]) / 32,
+ int(self.nbElem[2])),
+ (2 * int(self.nbElem[0]),
+ int(self.nbElem[1]),
+ int(self.nbElem[2]) / 32)
+ ],
+ [None,
+ None])
+
+ def setUp(self):
+ try:
+ self.platform = cl.get_platforms()[0]
+ self.device = self.platform.get_devices(cl.device_type.GPU)[0]
+ self.ctx = cl.Context([self.device])
+ self.queue = cl.CommandQueue(self.ctx, properties=cl.command_queue_properties.PROFILING_ENABLE)
+ f = open(pp.constants.GPU_SRC, 'r')
+ self.gpu_src = "".join(f.readlines())
+ f.close()
+ self.test = True
+ print "Testing on " + self.device.name
+ except Exception:
+ self.test = False
+ print "No tests because no GPU"
+
+ def tearDown(self):
+ pass
+
+ def test_apply_basic(self):
+ """Test advection basic"""
+ if self.test:
+ self.setUp_OpenCL_basic()
+ self.transport.discreteOperator.apply(0., 0.1, 0)
+ print self.scal.domain.step
+ self.queue.finish()
+ cl.enqueue_copy(self.queue, self.pos.data, self.pos.gpu_data)
+ cl.enqueue_copy(self.queue, self.scal.data, self.scal.gpu_data)
+ self.queue.finish()
+ print np.max(self.pos.data),np.min(self.pos.data)
+ print self.pos.data[1,1,1], self.true_pos.data[1,1,1]
+ np.testing.assert_array_almost_equal(self.pos.data, self.true_pos.data)
+ np.testing.assert_array_almost_equal(self.scal.data, self.gscal.data)
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(
+ unittest.TestLoader().loadTestsFromTestCase(Transport_dTestCase)
+ )
diff --git a/HySoP/hysop/test/test_particular_solvers/__init__.py b/HySoP/hysop/test/test_particular_solvers/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/hysop/test/test_particular_solvers/test_EDO_erreur.py b/HySoP/hysop/test/test_particular_solvers/test_EDO_erreur.py
new file mode 100644
index 0000000000000000000000000000000000000000..c07c30400d9c533aea1ff1e0f16069258d0b7c8e
--- /dev/null
+++ b/HySoP/hysop/test/test_particular_solvers/test_EDO_erreur.py
@@ -0,0 +1,171 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+from parmepy.particular_solvers.integrator.euler import Euler
+from parmepy.particular_solvers.integrator.runge_kutta2 import RK2
+from parmepy.particular_solvers.integrator.runge_kutta3 import RK3
+from parmepy.particular_solvers.integrator.runge_kutta4 import RK4
+from math import *
+import unittest
+import numpy as np
+import numpy.testing as npt
+import copy
+import matplotlib.pyplot as plt
+from parmepy.constants import *
+
+
+class test_EDO(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+
+ def analyticalSolution(self,t, x, y, z):
+ sx = (t*np.exp(t) + 1.) * np.exp(-t)
+ sy = (t*np.exp(t) + 1.) * np.exp(-t)
+ sz = (t*np.exp(t) + 1.) * np.exp(-t)
+ return sx, sy, sz
+
+ def f (self, t, u):
+ fx = -u[0][:,:,:] + t + 1.
+ fy = -u[1][:,:,:] + t + 1.
+ fz = -u[2][:,:,:] + t + 1.
+ return fx , fy ,fz
+
+ def testIntegratorEDO(self):
+ # Parameters
+ nb = 32
+ timeStep = 0.1
+ finalTime = 1.0
+ multi = 2.
+ maxerror=0.
+
+ t0 = time.time()
+ self.t = 0.
+ ## Domain
+ box = pp.Box(3, length=[4.*np.pi, 4.*np.pi, 4.*np.pi],
+ origin=[- 2.*np.pi,- 2.*np.pi,- 2.*np.pi])
+
+
+#####################################################################################
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3, periods=[False, False, False])
+
+ Result=np.asarray([np.zeros([nb, nb, nb],
+ dtype=PARMES_REAL, order=ORDER) for d in xrange(3)])
+ Analvorty=np.asarray([np.zeros([nb, nb, nb],
+ dtype=PARMES_REAL, order=ORDER) for d in xrange(3)])
+
+ compteur = 0
+ taille = int(finalTime / timeStep) +1
+ compteur = 0
+ dt = np.zeros([taille], dtype=PARMES_REAL, order=ORDER)
+ errEuler = np.zeros([taille], dtype=PARMES_REAL, order=ORDER)
+ errRK2 = np.zeros([taille], dtype=PARMES_REAL, order=ORDER)
+ errRK3 = np.zeros([taille], dtype=PARMES_REAL, order=ORDER)
+ errRK4 = np.zeros([taille], dtype=PARMES_REAL, order=ORDER)
+ UEuler = np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL,
+ order=ORDER) for d in xrange(3)])
+ URK2 = np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL,
+ order=ORDER) for d in xrange(3)])
+ URK3 = np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL,
+ order=ORDER) for d in xrange(3)])
+ URK4 = np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL,
+ order=ORDER) for d in xrange(3)])
+
+ UEuler[:,:,:,:] = 1.
+ URK2[:,:,:,:] = 1.
+ URK3[:,:,:,:] = 1.
+ URK4[:,:,:,:] = 1.
+
+ Analvorty[:,:,:,:]=np.vectorize(self.analyticalSolution)(timeStep,
+ topo3D.mesh.coords[0], \
+ topo3D.mesh.coords[1], \
+ topo3D.mesh.coords[2])[:]
+
+ while self.t < finalTime :
+ print "t", self.t
+
+ # Euler
+ self.method= Euler
+ methodInt=self.method(self.f)
+ Result = methodInt.integrate(self.f, self.t , timeStep , UEuler)
+ UEuler = Result
+ errEuler[compteur]= np.max (abs(Analvorty[:,:,:,:] - Result[:,:,:,:]))
+
+ # RK2
+ self.method= RK2
+ methodInt=self.method(self.f)
+ Result = methodInt.integrate(self.f, self.t , timeStep , URK2)
+ URK2 = Result
+ errRK2[compteur]= np.max (abs(Analvorty[:,:,:,:] - Result[:,:,:,:]))
+
+ # RK3
+ self.method= RK3
+ methodInt=self.method(self.f)
+ Result = methodInt.integrate(self.f, self.t , timeStep , URK3)
+ URK3 = Result
+ errRK3[compteur]= np.max (abs(Analvorty[:,:,:,:] - Result[:,:,:,:]))
+
+ # RK4
+ self.method= RK4
+ methodInt=self.method(self.f)
+ Result = methodInt.integrate(self.f, self.t , timeStep , URK4)
+ URK4 = Result
+ errRK4[compteur]= np.max (abs(Analvorty[:,:,:,:] - Result[:,:,:,:]))
+ dt[compteur] = self.t
+
+ self.t = self.t + timeStep
+ Analvorty[:,:,:,:]=np.vectorize(self.analyticalSolution)(self.t + timeStep,
+ topo3D.mesh.coords[0], \
+ topo3D.mesh.coords[1], \
+ topo3D.mesh.coords[2])[:]
+ compteur = compteur + 1
+
+ # Check the convergence order of each time integration scheme :
+ npt.assert_array_less(errEuler,timeStep)
+ npt.assert_array_less(errRK2,timeStep**2)
+ npt.assert_array_less(errRK3,timeStep**3)
+ npt.assert_array_less(errRK4,timeStep**4)
+
+ ## Table of error values
+# print "erreur Euler", errEuler
+# print "erreur RK2", errRK2
+# print "erreur RK3", errRK3
+# print "erreur RK4", errRK4
+
+ ## Plot error_scheme vs time
+# plt.figure(1)
+# plt.subplot(211)
+# plt.xlabel('dt')
+# plt.xscale('log')
+# plt.ylabel('Erreur')
+# plt.yscale('log')
+# plt.plot(dt, errEuler, '+-',dt ,errRK2, '+-' ,dt, errRK3, '+-',dt,errRK4, '+-')
+# plt.legend([u"Euler", u"RK2", u"RK3", u"RK4"], loc=4)
+# plt.subplot(212)
+# plt.xlabel('dt')
+# plt.ylabel('Erreur')
+# plt.plot(dt, errEuler, '+-',dt ,errRK2, '+-' ,dt, errRK3, '+-',dt,errRK4, '+-')
+# plt.legend([u"Euler", u"RK2", u"RK3", u"RK4"], loc=4)
+
+ plt.show()
+
+ t1 = time.time()
+
+ print "\n"
+# print "Total time : ", tf - t0, "sec (CPU)"
+# print "Init time : ", t1 - t0, "sec (CPU)"
+# print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testIntegratorEDO()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_EDO))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_particular_solvers/test_RK.py b/HySoP/hysop/test/test_particular_solvers/test_RK.py
new file mode 100644
index 0000000000000000000000000000000000000000..70ed6aa89bd3738f3288274aa1189815eb6c011d
--- /dev/null
+++ b/HySoP/hysop/test/test_particular_solvers/test_RK.py
@@ -0,0 +1,154 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+from parmepy.particular_solvers.integrator.euler import Euler
+from parmepy.particular_solvers.integrator.runge_kutta2 import RK2
+from parmepy.particular_solvers.integrator.runge_kutta3 import RK3
+from parmepy.particular_solvers.integrator.runge_kutta4 import RK4
+from parmepy.particular_solvers.integrator.runge_kutta2stretching import RK2Stretch
+from parmepy.particular_solvers.integrator.runge_kutta3stretching import RK3Stretch
+from parmepy.particular_solvers.integrator.runge_kutta4stretching import RK4Stretch
+from math import *
+import unittest
+import numpy as np
+import numpy.testing as npt
+import copy
+import matplotlib.pyplot as plt
+from parmepy.constants import *
+
+
+
+class test_RK(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+
+ def vitesse(self, x, y, z):
+ vx = np.sin(x)
+ vy = np.sin(y)
+ vz = np.sin(z)
+ return vx, vy, vz
+
+ def vorticite(self, x, y, z):
+ wx = self.t**2+1.
+ wy = self.t**2+1.
+ wz = self.t**2+1.
+ return wx, wy, wz
+
+ def analyticalSolution(self,t, x, y, z):
+ sx = t**2 - (t + t**3 /3.) * np.cos(x)
+ sy = t**2 - (t + t**3 /3.) * np.cos(y)
+ sz = t**2 - (t + t**3 /3.) * np.cos(z)
+ return sx, sy, sz
+
+ def f (self, t, u):
+ fx = 2.*t -u[0][:,:,:]
+ fy = 2.*t -u[1][:,:,:]
+ fz = 2.*t -u[2][:,:,:]
+ return fx , fy ,fz
+
+
+ def wgradu (self, t, x, y, z) :
+ wx =( 1 + t**2 )* np.cos(x)
+ wy =( 1 + t**2 )* np.cos(y)
+ wz =( 1 + t**2 )* np.cos(z)
+ return wx, wy, wz
+
+
+ def testIntegratorRK(self):
+ # Parameters
+ nb = 32
+ timeStep = 0.01
+ finalTime = 0.01
+ maxerror=0.
+
+ t0 = time.time()
+ self.t = 0.
+ ## Domain
+ box = pp.Box(3, length=[4.*np.pi, 4.*np.pi, 4.*np.pi], origin=[- 2.*np.pi,- 2.*np.pi,- 2.*np.pi])
+
+
+#####################################################################################
+
+ ## Fields
+# velo = pp.AnalyticalField(domain=box, formula=self.vitesse, name='Velocity', vector=True)
+# vorti = pp.AnalyticalField(domain=box, formula=self.vorticite, name='Vorticity', vector=True)
+
+ ## Operators
+# stretch = pp.Stretching(velo,vorti)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=box, resolution=[nb, nb, nb], dim=3)
+
+ ##Problem
+# pb = pp.Problem(topo3D, [stretch])
+
+ ## Setting solver to Problem
+# pb.setSolver(finalTime, timeStep, solver_type='basic')
+
+ Result=np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL, order=ORDER) for d in xrange(3)])
+ Analvorty=np.asarray([np.zeros([nb, nb, nb], dtype=PARMES_REAL, order=ORDER) for d in xrange(3)])
+ Analvorty[:,:,:,:]= np.vectorize(self.wgradu)(self.t,topo3D.mesh.coords[0], \
+ topo3D.mesh.coords[1], \
+ topo3D.mesh.coords[2])[:]
+
+ self.method= RK3 # RK3Stretch #RK2Stretch #RK4Stretch #Euler #RK4 #
+
+ print "\nODE SOLVER :: ", self.method
+
+ methodInt=self.method(self.f)
+ Result = methodInt.integrate(self.f, self.t , timeStep , self.wgradu, topo3D)
+
+ if Euler == self.method :
+ maxerror = abs((timeStep**2 - 1./3. * timeStep**3)-.0) + timeStep**3
+ if RK2 == self.method :
+ maxerror = abs((-1./3. * timeStep**3) - (0.5* timeStep**2)) + timeStep**8
+ if RK3 == self.method :
+ maxerror = abs(0. - (0.5* timeStep**2 - 1./6. * timeStep**3)) + timeStep**3
+ if RK4 == self.method :
+ maxerror = abs((timeStep**2 - 1./3. * timeStep**3) - (7./6.* timeStep**2 - 1./2. * timeStep**3 + 1./8. * timeStep**4))
+
+
+# pb.initSolver()
+ t1 = time.time()
+
+ ## Solve problem
+# pb.solve()
+ self.t = self.t + timeStep
+ Analvorty[:,:,:,:]=Analvorty[:,:,:,:]+np.vectorize(self.analyticalSolution)(self.t, topo3D.mesh.coords[0], \
+ topo3D.mesh.coords[1], \
+ topo3D.mesh.coords[2])[:]
+
+## Visual comparison between the numerical resolution and the analytical resolution
+ for i in range(1):
+ plt.figure(1)
+ plt.subplot(211)
+ plt.axis([-2*np.pi,2*np.pi,np.min(Analvorty[i][:,0,0]),np.max(Analvorty[i][:,0,0])])
+ plt.plot(topo3D.mesh.coords[0][:,0,0], Analvorty[i][:,0,0], '-' ,topo3D.mesh.coords[0][:,0,0],Result[i][:,0,0], '-' )
+ plt.legend([u"Solution Analytique", u"Solution Numérique"])
+ plt.subplot(212)
+ plt.axis([-2*np.pi,2*np.pi,0,max(abs(Analvorty[i][:,0,0] - Result[i][:,0,0]))])
+ plt.plot(topo3D.mesh.coords[0][:,0,0], abs(Analvorty[i][:,0,0] - Result[i][:,0,0]), '-' )
+ plt.legend([u"Erreur"])
+ plt.ax = plt.gca()
+ plt.ax.ticklabel_format(style='sci', axis='y')
+ plt.show()
+ npt.assert_array_less(abs(Analvorty[:,:,:,:] - Result[:,:,:,:]),maxerror)
+ tf = time.time()
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testIntegratorRK()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_RK))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_particular_solvers/test_euler.py b/HySoP/hysop/test/test_particular_solvers/test_euler.py
new file mode 100644
index 0000000000000000000000000000000000000000..12b0dac2d63981b7f5f3736e9143f05d94871af2
--- /dev/null
+++ b/HySoP/hysop/test/test_particular_solvers/test_euler.py
@@ -0,0 +1,114 @@
+# -*- coding: utf-8 -*-
+import unittest
+from parmepy.fields.discrete import *
+from parmepy.fields.continuous import *
+from parmepy.fields.analytical import *
+from parmepy.domain.topology import *
+from parmepy.domain.box import *
+from parmepy.constants import *
+from parmepy.particular_solvers.integrator.integrator import ODESolver
+from parmepy.particular_solvers.integrator.euler import Euler
+import numpy as np
+import numpy.testing as npt
+import math
+
+
+class test_Euler(unittest.TestCase):
+ """
+ Euler test
+ solve u'(t) = f( u(t),t )
+ u(t) = a t + U0
+ f(u,t) = a + (u - (at + U0))^4
+ """
+ def setUp(self):
+ self.e = 0.0002 # Accepted error between result and analytical result
+ self.dim = 3
+ self.boxLength = [1., 1., 1.]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [6, 6, 6]
+ self.box = Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+ self.dt = 0.1
+ self.FinalTime = 3
+ self.U0 = [1.0 , 2.0, 3.0 ]
+
+ def testEulerInt(self):
+ # Continuous fields and operator declaration
+ self.velo = AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+ # Topology definition / Fields and operator discretization
+ self.result = [np.ones((self.nbPts), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ self.topo3D = CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim)
+ self.velo.discretize(self.topo3D)
+ self.velo.initialize()
+ self.resol = self.topo3D.mesh.resolution
+ #test for t=0 and initialization of the fonction f
+ t = 0.
+ fctInter = [np.ones((self.nbPts), dtype=PARMES_REAL, order=ORDER) for d in xrange(self.dim)]
+ method = Euler()
+
+ #Solution calculated with Euler
+ fctInter = self.fctTest(t,self.velo.discreteField[self.velo._fieldId].data[0]\
+ ,self.velo.discreteField[self.velo._fieldId].data[1]\
+ ,self.velo.discreteField[self.velo._fieldId].data[2])
+ for d in xrange(self.dim) :
+ self.result[d][...] = method.integrate(self.velo.discreteField[self.velo._fieldId], fctInter, t, self.dt, d )
+
+ t=t+self.dt
+
+ #Analytical solution
+ self.anal=self.analyticalSolution(t,self.velo.discreteField[self.velo._fieldId].data[0]\
+ ,self.velo.discreteField[self.velo._fieldId].data[1]\
+ ,self.velo.discreteField[self.velo._fieldId].data[2])
+ npt.assert_array_less(abs(self.anal[0]-self.result[0]), self.e)
+ npt.assert_array_less(abs(self.anal[1]-self.result[1]), self.e)
+ npt.assert_array_less(abs(self.anal[2]-self.result[2]), self.e)
+
+ # time loop
+ while t < self.FinalTime :
+ #print "T=" , t
+ fctInter = self.fctTest(t,self.result[0],self.result[1],self.result[2])
+ for d in xrange(self.dim) :
+ self.result[d][...] = method.integrate(self.result, fctInter, t, self.dt, d )
+
+ t = t + self.dt
+
+ self.anal=self.analyticalSolution(t,self.velo.discreteField[self.velo._fieldId].data[0]\
+ ,self.velo.discreteField[self.velo._fieldId].data[1]\
+ ,self.velo.discreteField[self.velo._fieldId].data[2])
+ # Comparison with analytical solution
+ npt.assert_array_less(abs(self.anal[0]-self.result[0]), self.e)
+ npt.assert_array_less(abs(self.anal[1]-self.result[1]), self.e)
+ npt.assert_array_less(abs(self.anal[2]-self.result[2]), self.e)
+
+
+ def vitesse(self, x, y, z):
+ vx = 1.0
+ vy = 2.0
+ vz = 3.0
+ return vx, vy, vz
+
+ def fctTest(self, t, x, y, z):
+ wx = 0.2 +( x - self.analyticalSolution(t, 1., 2., 3.)[0])**4
+ wy = 0.5 +( y - self.analyticalSolution(t, 1., 2., 3.)[1])**4
+ wz = 1. +( z - self.analyticalSolution(t, 1., 2., 3.)[2])**4
+ return [wx,wy,wz]
+
+ def analyticalSolution(self, t, x, y, z):
+ sx = 0.2 *t + x
+ sy = 0.5 *t + y
+ sz = 1. *t + z
+ return [sx, sy, sz]
+
+ def runTest(self):
+ self.setUp()
+ self.testOperatorDiv()
+
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Euler))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/HySoP/hysop/test/test_tools/__init__.py b/HySoP/hysop/test/test_tools/__init__.py
new file mode 100755
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/hysop/tools/tests/test_timers.py b/HySoP/hysop/tools/tests/test_timers.py
new file mode 100644
index 0000000000000000000000000000000000000000..43ab6691887e3a624392c055488be61c0afc7ec7
--- /dev/null
+++ b/HySoP/hysop/tools/tests/test_timers.py
@@ -0,0 +1,44 @@
+"""
+Unitary tests for parmepy.tools.timers module
+"""
+from parmepy.tools.timers import Timer, timed_function
+
+
+class A_class(object):
+ def __init__(self):
+ self.name = 'A_class'
+ self.timer = Timer(self)
+ self.n = 0
+
+ @timed_function
+ def call(self):
+ self.n += 1
+
+ @timed_function
+ def call_other(self):
+ self.n += 10
+
+
+def test_timer_from_decorator():
+ a = A_class()
+ assert a.n == 0
+ a.call()
+ assert len(a.timer.f_timers.keys()) == 1
+ fun1 = a.timer.f_timers.keys()[0]
+ assert a.n == 1 # the call function have been called
+ assert a.timer.f_timers[fun1].ncalls == 1
+ #assert a.timer.f_timers[fun1].t == a.timer.f_timers[fun1].times[0]
+ a.call()
+ a.call_other()
+ assert len(a.timer.f_timers.keys()) == 2
+ fun2 = [f for f in a.timer.f_timers.keys() if f != fun1][0]
+ assert a.n == 12 # the call and call_other functions have been called
+ assert a.timer.f_timers[fun1].ncalls == 2
+ #assert a.timer.f_timers[fun1].t == \
+ # a.timer.f_timers[fun1].times[0] + a.timer.f_timers[fun1].times[1]
+ assert a.timer.f_timers[fun2].ncalls == 1
+ #assert a.timer.f_timers[fun2].t == a.timer.f_timers[fun2].times[0]
+
+
+if __name__ == '__main__':
+ test_timer_from_decorator()
diff --git a/HySoP/hysop/tools/timers.py b/HySoP/hysop/tools/timers.py
new file mode 100644
index 0000000000000000000000000000000000000000..de2b5167ff79e1cea308f7e34618b6848d0ece47
--- /dev/null
+++ b/HySoP/hysop/tools/timers.py
@@ -0,0 +1,194 @@
+"""
+@file timers.py
+
+Contains class for monitoring computational time in a non-intrusive way
+thanks to decorator.
+"""
+from parmepy.mpi import MPI, main_rank
+from parmepy import __VERBOSE__
+ftime = MPI.Wtime
+
+
+def timed_function(f):
+ """
+ Decorator for function timing. Get the corresponding function timer in the
+ operator (represented in args[0]).
+
+ @remark : Works only with methods that belongs to object with Timer
+ member named timer.
+ """
+ def wrapper(*args, **kwargs):
+ f_timer = args[0].timer.getFunctionTimer(f)
+ res = f_timer(f)(*args, **kwargs)
+ return res
+ # def wrapper(*args, **kwargs):
+ # return f(*args, **kwargs)
+ return wrapper
+
+
+class FunctionTimer(object):
+ """
+ Class for timing functions with the timed_function decorator.
+
+ The FunctionTimer is instancied with a given function. Calling the timer
+ will call the function timed with execution time computation.
+ """
+
+ def __init__(self, func):
+ """
+ Creates a timer for the given function.
+
+ @param func : function to time.
+ """
+ ## Timed function name
+ self.func_name = func.func_name
+ ## Total time spent in the function (in seconds).
+ self.t = 0.
+ # ## Times per calls
+ # self.times = []
+ ## Calls number
+ self.ncalls = 0
+
+ def __call__(self, func):
+ """
+ The function given is wrapped with time computations instructions
+ through MPI.Wtime function.
+ It returns the wrapped function.
+ @param func function to time.
+ @return wrapped function.
+ """
+ def f(*args, **kwargs):
+ t0 = ftime()
+ res = func(*args, **kwargs)
+ t = ftime() - t0
+ self.t += t
+ self.ncalls += 1
+ #self.times.append(t)
+ if __VERBOSE__:
+ print (args[0].__class__.__name__, ' -- ',)
+ print (self.func_name, " : ", t, 's')
+ return res
+ return f
+
+ def __str__(self):
+ s = self.func_name
+ s += ' : ' + str(self.t) + " s ({0} calls)".format(self.ncalls)
+ return s
+
+
+class ManualFunctionTimer(FunctionTimer):
+ """
+ Class for manual timing some code. For instance, this class is desined for
+ monitoring OpenCL kernels where function call does not reflect
+ computational time.
+ """
+ def __init__(self, name):
+ def fun():
+ pass
+ fun.func_name = name
+ FunctionTimer.__init__(self, fun)
+
+ def append_time(self, t):
+ """Manual computational time append"""
+ self.t += t
+ self.ncalls += 1
+ #self.times.append(t)
+ if __VERBOSE__:
+ print (self.func_name, " : ", t, 's')
+
+
+class Timer(object):
+ """
+ Manages a dictionary of FunctionTimer objects for monitoring functions
+ member of the given operator.
+ """
+
+ def __init__(self, op, suffix=''):
+ """
+ Creates an Timer.
+ @param op : Timer owner.
+ """
+ ## Parent object name
+ self._obj = op
+ self.name = self._obj.name + suffix
+ ## FunctionTimer dictionary with functions or operators as keys.
+ self.f_timers = {}
+ ## Total time spent in the operator (in seconds).
+ self.t = 0.
+ self._isEmpty = True
+
+ def __add__(self, t):
+ """
+ Overrides operator +.
+ @param t : Other Timer object
+ """
+ t.compute_summary()
+ #self.t += t.t
+ self._isEmpty = False
+ self.f_timers[t] = t
+ return self
+
+ def getFunctionTimer(self, func):
+ """
+ Get the FunctionTimer related to given function, or created
+ if not exists.
+
+ @param func : Function to get the corresponding timer.
+ @return : FunctionTimer related to func.
+ """
+ try:
+ return self.f_timers[func]
+ except KeyError:
+ self.f_timers[func] = FunctionTimer(func)
+ return self.f_timers[func]
+
+ def addFunctionTimer(self, ft):
+ """
+ Add a function timer to Timer.
+
+ @param ft : FunctionTimer to add.
+ """
+ self.f_timers[ft] = ft
+
+ def addSubTimer(self, t, prefix=''):
+ if len(t.f_timers.keys()) > 0:
+ t.compute_summary()
+ t.name += prefix
+ self.f_timers[t] = t
+
+ def compute_summary(self):
+ """
+ Compute a summary of the different functions referenced herein.
+ """
+ self.t = 0.
+ for f in self.f_timers.keys():
+ # if self.f_timers[f] is a Timer, these times are already
+ # in the current Timer sum.
+ if not isinstance(self.f_timers[f], Timer):
+ self.t += self.f_timers[f].t
+ self._isEmpty = False
+
+ def rTimes(self):
+ s = ""
+ for f in sorted(self.f_timers.keys()):
+ nl = "@@F@@[" + str(main_rank) + "]@@S@@"
+ if isinstance(self.f_timers[f], Timer):
+ if len(self.f_timers[f].f_timers) > 0:
+ s += nl + ' |-- ' + f.name
+ if self.f_timers[f].t > 0.:
+ s += " : " + str(self.f_timers[f].t)
+ subTimer = self.f_timers[f]
+ s += subTimer.rTimes().replace('@@S@@', '@@S@@ ')
+ else:
+ s += nl + ' |-- ' + str(self.f_timers[f])
+ return s
+
+ def __str__(self):
+ self.compute_summary()
+ if not self._isEmpty:
+ s = "[" + str(main_rank) + "] Time spent in "
+ s += self.name + ' = ' + str(self.t) + ' s'
+ s += self.rTimes().replace('@@F@@', '\n').replace('@@S@@', '')
+ else:
+ s = ""
+ return s
diff --git a/HySoP/src/Unstable/LEGI/changelog b/HySoP/src/Unstable/LEGI/changelog
new file mode 100644
index 0000000000000000000000000000000000000000..d6e0a83471ac41f3b633942ef3ac2b40087dbb8f
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/changelog
@@ -0,0 +1,16 @@
+2012-XX-XX X.X
+[new] Adding 2 new scheme into particles methods: lambda 4 corrected
+ (fourth psace order, corrected for large time step) and M'6
+[optim] Faster particles method.
+
+2012-02-23 1.0
+[new] Parallel fft.
+[new] Parallel pseudo spectral solver for NS equation and convection-diffusion problem.
+[new] Advection solver based on particles method.
+[new] Avs i/o in parallel context only in the spectral solver context.
+[new] Distribued vtk xml output in context of advection solver.
+[new] Both spectral and particle solver used the same mpi-topology.
+[new] Solve scalar equation with particles method mixed to spectral solver.
+[new] Use different resolution for velocity and scalars (for all scalars solvers)
+[new] Post-processing: obtain spectrum
+[optim] Optimisation of advection solver based on particles methods.
diff --git a/HySoP/src/Unstable/LEGI/doc/benchmark/Benchmark/description.tex b/HySoP/src/Unstable/LEGI/doc/benchmark/Benchmark/description.tex
new file mode 100644
index 0000000000000000000000000000000000000000..cd5fb817a67976632409c2f9e290c54826d956fc
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/benchmark/Benchmark/description.tex
@@ -0,0 +1,49 @@
+%-----------------------------------------------------------------------------------------------------------------
+%--------------------------------------------------- Algo basique ----------------------------------------------------
+%-----------------------------------------------------------------------------------------------------------------
+
+\section{Mathematical description of the benchmarks}
+
+ Different benchmark are provided. The purpose is to evaluate the advection solver and its implement in both simple cases and complex cases.For reader convenience, let us sum up all these benchmark :
+\begin{enumerate}
+ \item 2D turning sphere : simple case where analytic solution are known.
+ \item Radial constant field with a velocity involving shear: this test-case allows to test how efficient the solver is in complex cases with large time step. The analytic solution is known.
+\end{enumerate}
+
+
+\subsection{(2D-)Turning sphere}
+
+ Let us denote by $\Omega = [0,1]^2$ the numerical domain.
+
+ The velocity field is defined by:
+\begin{equation}
+ \vect{v}\bigl( \begin{smallmatrix} x \\y \end{smallmatrix} \bigr) = \frac{2\pi}{T} \Biggl( \begin{matrix} 0.5 -y \\ x - 0.5 \end{matrix} \Biggr)
+\end{equation}
+with the period $T=1$ and $r_0 = \min(dx, dy)$ where $dx$, $dy$ denote the space step .
+ The scalar is initialized as following :
+\begin{equation}
+ u \bigl( \begin{smallmatrix} x \\y \end{smallmatrix} \bigr) = \begin{cases}
+ 0 & \text{if $r^2 = \bigl(x - 3/5 \bigr)^2 + \bigl(y - 3/5 \bigr)^2 > r_0^2$}
+ \\ \bigl( 1 - r^2/r_0^2)^4 \bigr) & \text{else, with $r^2 = \bigl(x - 3/5 \bigr)^2 + \bigl(y - 3/5 \bigr)^2$}
+ \end{cases}
+\end{equation}
+
+ The analytic solution at time t consists of a rotation of the initial scalar value along Z-axis of angle $\frac{2\pi}{T} \times t$.
+
+\subsection{Radial constant field with a velocity involving shear}
+
+ Let us denote by $\Omega = [-1,1]^2$ the numerical domain.
+
+ The velocity field is defined by:
+\begin{equation}
+ \vect{v}\bigl( \begin{smallmatrix} x \\y \end{smallmatrix} \bigr) = \cos\Bigl( \frac{3\pi}{2} \Bigr) \bigl( \begin{smallmatrix} -y \\ x \end{smallmatrix} \bigr)
+\end{equation}
+ The scalar is initialized as following :
+\begin{equation}
+ u \bigl( \begin{smallmatrix} x \\y \end{smallmatrix} \bigr) = \begin{cases}
+ 0 & \text{if $r^2 = x^2 + y^2 > 1$}
+ \\ \bigl( 1 - r^2)^6 \bigr) & \text{else, with $r^2 = x^2 + y^2$}
+ \end{cases}
+\end{equation}
+
+ As the radial component of the velocity vanishes, the initial scalar value match to a stationary solution. Therefore, the scalar field remains constant. As there is some tangent shear, this test will show how the implementation deals with large time step. For instance, if it is based on $\Lambda_{\tilde{2}}$ or $\Lambda_{\tilde{4}}$ remeshing formula, the corrected cases will appears (\ie some particles will be tagged). Note that for a CFL number larger than one, classical $\lambda_6$ formula are only of order 1.
\ No newline at end of file
diff --git a/HySoP/src/Unstable/LEGI/doc/benchmark/bench.pdf b/HySoP/src/Unstable/LEGI/doc/benchmark/bench.pdf
new file mode 100644
index 0000000000000000000000000000000000000000..7b051d7e5f9586d2d1b4061fec2fedfe44837df4
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/benchmark/bench.pdf differ
diff --git a/HySoP/src/Unstable/LEGI/doc/benchmark/bench.tex b/HySoP/src/Unstable/LEGI/doc/benchmark/bench.tex
new file mode 100644
index 0000000000000000000000000000000000000000..94b8a7b61ac3648667202f37dfe0b364ada84b99
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/benchmark/bench.tex
@@ -0,0 +1,131 @@
+
+%-----------------------------------------------------------------------------------------------------------------
+%--------------------------------------------------- Préambule ----------------------------------------------------
+%-----------------------------------------------------------------------------------------------------------------
+
+\documentclass[a4paper, 12pt, twoside, openright]{article}
+
+
+%--------------------------------------------------- Packages -----------------------------------------------------
+ % Basiques
+\usepackage[T1]{fontenc}
+\usepackage[english, french]{babel} % parce que le texte est en français
+\usepackage[utf8]{inputenc} % pour avoir les accents (car encodage en utf8)
+
+ % Mathématiques
+\usepackage{amssymb}
+\usepackage{amsmath}
+\usepackage{amsfonts}
+\usepackage{amsthm}
+\usepackage{amsxtra}
+
+ % Figures
+\usepackage{graphicx} % pour insérer et mettre en page des figures
+\usepackage{algorithm} % pour mettre en page des algorithmes
+\usepackage{algorithmic}
+\usepackage{subfigure} % pour mettre des figures côte à côtes.
+\usepackage{tikz} % pour insérer des figures via Tkiz
+%\usepackage{gnuplot-lua-tikz} % version modifier de Tikz pour utiliser les sortie gnuplot-lua
+\usetikzlibrary{%
+ calc,%
+ through,%
+ intersections,%
+ arrows,%
+ shapes.misc,% wg. rounded rectangle
+ shapes.geometric,%
+ chains,%
+ positioning,% wg. " of "
+ scopes,%
+ backgrounds,%
+ fit,%
+ mindmap,%
+ plotmarks
+ }
+%\usepackage[margin=10pt,font=small, labelfont=bf, labelsep=endash]{caption}
+ % Pour avoir des légendes d'images "plus mieux"
+
+ % Tableau
+\usepackage{multirow} % Pour fusionner des lignes
+
+
+ % Outils et rédaction
+\usepackage{url} % pour pouvoir mettre des url.
+\urlstyle{sf}
+
+
+% Pour la rédaction :
+\usepackage{pdfsync} % lorsque l'on clique sur le pdf, on arrive à la bonne ligne de code du .tex
+\usepackage[disable, textsize=tiny, french, textwidth=2.cm, color=orange!60!, linecolor=black]{todonotes}
+
+\usepgfmodule{plot}
+
+
+
+%----------------------------------------------------- Paramètres ------------------------------------------------------
+
+% ///// Auteur, titre /////
+
+\author{Jean-Baptiste Lagaert}
+\title{Benchmark for advection solver based on particles method}
+
+
+% ///// Nouvelles commandes et paramètres /////
+
+% Paramètres
+\graphicspath{{../Figures/}} % Répertoire contenant les illustrations
+
+% Numérotations
+\numberwithin{equation}{section} % Numérotation des équations par section
+\setcounter{tocdepth}{1} % Profondeur maximale des titres dans la table des matières
+
+
+% Nouvelles commandes
+ % Pour les dérivées partielles :
+\newcommand{\dt}{\partial_t}
+\newcommand{\dx}{\partial_x}
+\newcommand{\dy}{\partial_y}
+\newcommand{\dz}{\partial_z}
+\newcommand{\dn}{\partial_n}
+ % Lemma and remarks :
+\theoremstyle{plain}% default
+\newtheorem{thm}{Théorème}[section]
+\newtheorem{lem}[thm]{Lemme}
+\newtheorem{lemEng}[thm]{Lemma}
+\newtheorem{prop}[thm]{Proposition}
+\theoremstyle{remark}
+\newtheorem*{rem}{Remarque}
+\newtheorem*{rem_en}{Remark}
+ % Quelques raccourcis :
+\newcommand{\R}{\mathbb{R}}
+\newcommand{\ie}{\emph{ie }}
+\newcommand{\vect}[1]{\mathbf{#1}}
+\newcommand{\el}{\emph{eLYSe }}
+ %Other
+\newcommand{\Lag}{\mathcal{L}}
+\newcommand{\J}{\mathcal{J}}
+%\floatname{algorithm}{Algorithme} % Francisation de l'environnement algorithm
+
+%\input{Divers/page_garde}
+
+%-----------------------------------------------------------------------------------------------------------------
+%-------------------------------------------------- Document -----------------------------------------------------
+%----------------------------------------------------------------------------------------------------------------
+
+\begin{document}
+
+\maketitle
+
+
+\begin{otherlanguage}{english}
+%\begin{hyphenrules}{english}
+
+Some benchmark are provided in order to measure the implementation efficiency, the drawback and the benefits of our numerical method and there precision. These tests are design in order to present "easy" cases as complex cases hard to simulate.
+\vspace{1cm}
+
+\input{Benchmark/description}
+%\input{Benchmark/setup}
+%\input{Benchmark/resultats}
+%\end{hyphenrules}
+\end{otherlanguage}
+
+\end{document}
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/Doxyfile b/HySoP/src/Unstable/LEGI/doc/doxygen/Doxyfile
new file mode 100644
index 0000000000000000000000000000000000000000..15804ff83fd2631c25ac6619cd93a9163feaa3b2
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/Doxyfile
@@ -0,0 +1,1525 @@
+# Doxyfile 1.5.9
+
+# This file describes the settings to be used by the documentation system
+# doxygen (www.doxygen.org) for a project
+#
+# All text after a hash (#) is considered a comment and will be ignored
+# The format is:
+# TAG = value [value, ...]
+# For lists items can also be appended using:
+# TAG += value [value, ...]
+# Values that contain spaces should be placed between quotes (" ")
+
+#---------------------------------------------------------------------------
+# Project related configuration options
+#---------------------------------------------------------------------------
+
+# This tag specifies the encoding used for all characters in the config file
+# that follow. The default is UTF-8 which is also the encoding used for all
+# text before the first occurrence of this tag. Doxygen uses libiconv (or the
+# iconv built into libc) for the transcoding. See
+# http://www.gnu.org/software/libiconv for the list of possible encodings.
+
+DOXYFILE_ENCODING = UTF-8
+
+# The PROJECT_NAME tag is a single word (or a sequence of words surrounded
+# by quotes) that should identify the project.
+
+PROJECT_NAME = codescalar
+
+# The PROJECT_NUMBER tag can be used to enter a project or revision number.
+# This could be handy for archiving the generated documentation or
+# if some version control system is used.
+
+PROJECT_NUMBER = 1
+
+# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute)
+# base path where the generated documentation will be put.
+# If a relative path is entered, it will be relative to the location
+# where doxygen was started. If left blank the current directory will be used.
+
+OUTPUT_DIRECTORY = ./codescalar_doc
+
+# If the CREATE_SUBDIRS tag is set to YES, then doxygen will create
+# 4096 sub-directories (in 2 levels) under the output directory of each output
+# format and will distribute the generated files over these directories.
+# Enabling this option can be useful when feeding doxygen a huge amount of
+# source files, where putting all generated files in the same directory would
+# otherwise cause performance problems for the file system.
+
+CREATE_SUBDIRS = NO
+
+# The OUTPUT_LANGUAGE tag is used to specify the language in which all
+# documentation generated by doxygen is written. Doxygen will use this
+# information to generate all constant output in the proper language.
+# The default language is English, other supported languages are:
+# Afrikaans, Arabic, Brazilian, Catalan, Chinese, Chinese-Traditional,
+# Croatian, Czech, Danish, Dutch, Esperanto, Farsi, Finnish, French, German,
+# Greek, Hungarian, Italian, Japanese, Japanese-en (Japanese with English
+# messages), Korean, Korean-en, Lithuanian, Norwegian, Macedonian, Persian,
+# Polish, Portuguese, Romanian, Russian, Serbian, Serbian-Cyrilic, Slovak,
+# Slovene, Spanish, Swedish, Ukrainian, and Vietnamese.
+
+OUTPUT_LANGUAGE = English
+
+# If the BRIEF_MEMBER_DESC tag is set to YES (the default) Doxygen will
+# include brief member descriptions after the members that are listed in
+# the file and class documentation (similar to JavaDoc).
+# Set to NO to disable this.
+
+BRIEF_MEMBER_DESC = YES
+
+# If the REPEAT_BRIEF tag is set to YES (the default) Doxygen will prepend
+# the brief description of a member or function before the detailed description.
+# Note: if both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the
+# brief descriptions will be completely suppressed.
+
+REPEAT_BRIEF = YES
+
+# This tag implements a quasi-intelligent brief description abbreviator
+# that is used to form the text in various listings. Each string
+# in this list, if found as the leading text of the brief description, will be
+# stripped from the text and the result after processing the whole list, is
+# used as the annotated text. Otherwise, the brief description is used as-is.
+# If left blank, the following values are used ("$name" is automatically
+# replaced with the name of the entity): "The $name class" "The $name widget"
+# "The $name file" "is" "provides" "specifies" "contains"
+# "represents" "a" "an" "the"
+
+ABBREVIATE_BRIEF =
+
+# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then
+# Doxygen will generate a detailed section even if there is only a brief
+# description.
+
+ALWAYS_DETAILED_SEC = YES
+
+# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all
+# inherited members of a class in the documentation of that class as if those
+# members were ordinary class members. Constructors, destructors and assignment
+# operators of the base classes will not be shown.
+
+INLINE_INHERITED_MEMB = NO
+
+# If the FULL_PATH_NAMES tag is set to YES then Doxygen will prepend the full
+# path before files name in the file list and in the header files. If set
+# to NO the shortest path that makes the file name unique will be used.
+
+FULL_PATH_NAMES = NO
+
+# If the FULL_PATH_NAMES tag is set to YES then the STRIP_FROM_PATH tag
+# can be used to strip a user-defined part of the path. Stripping is
+# only done if one of the specified strings matches the left-hand part of
+# the path. The tag can be used to show relative paths in the file list.
+# If left blank the directory from which doxygen is run is used as the
+# path to strip.
+
+STRIP_FROM_PATH =
+
+# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of
+# the path mentioned in the documentation of a class, which tells
+# the reader which header file to include in order to use a class.
+# If left blank only the name of the header file containing the class
+# definition is used. Otherwise one should specify the include paths that
+# are normally passed to the compiler using the -I flag.
+
+STRIP_FROM_INC_PATH =
+
+# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter
+# (but less readable) file names. This can be useful is your file systems
+# doesn't support long names like on DOS, Mac, or CD-ROM.
+
+SHORT_NAMES = NO
+
+# If the JAVADOC_AUTOBRIEF tag is set to YES then Doxygen
+# will interpret the first line (until the first dot) of a JavaDoc-style
+# comment as the brief description. If set to NO, the JavaDoc
+# comments will behave just like regular Qt-style comments
+# (thus requiring an explicit @brief command for a brief description.)
+
+JAVADOC_AUTOBRIEF = NO
+
+# If the QT_AUTOBRIEF tag is set to YES then Doxygen will
+# interpret the first line (until the first dot) of a Qt-style
+# comment as the brief description. If set to NO, the comments
+# will behave just like regular Qt-style comments (thus requiring
+# an explicit \brief command for a brief description.)
+
+QT_AUTOBRIEF = NO
+
+# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make Doxygen
+# treat a multi-line C++ special comment block (i.e. a block of //! or ///
+# comments) as a brief description. This used to be the default behaviour.
+# The new default is to treat a multi-line C++ comment block as a detailed
+# description. Set this tag to YES if you prefer the old behaviour instead.
+
+MULTILINE_CPP_IS_BRIEF = NO
+
+# If the INHERIT_DOCS tag is set to YES (the default) then an undocumented
+# member inherits the documentation from any documented member that it
+# re-implements.
+
+INHERIT_DOCS = YES
+
+# If the SEPARATE_MEMBER_PAGES tag is set to YES, then doxygen will produce
+# a new page for each member. If set to NO, the documentation of a member will
+# be part of the file/class/namespace that contains it.
+
+SEPARATE_MEMBER_PAGES = NO
+
+# The TAB_SIZE tag can be used to set the number of spaces in a tab.
+# Doxygen uses this value to replace tabs by spaces in code fragments.
+
+TAB_SIZE = 8
+
+# This tag can be used to specify a number of aliases that acts
+# as commands in the documentation. An alias has the form "name=value".
+# For example adding "sideeffect=\par Side Effects:\n" will allow you to
+# put the command \sideeffect (or @sideeffect) in the documentation, which
+# will result in a user-defined paragraph with heading "Side Effects:".
+# You can put \n's in the value part of an alias to insert newlines.
+
+ALIASES =
+
+# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C
+# sources only. Doxygen will then generate output that is more tailored for C.
+# For instance, some of the names that are used will be different. The list
+# of all members will be omitted, etc.
+
+OPTIMIZE_OUTPUT_FOR_C = NO
+
+# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java
+# sources only. Doxygen will then generate output that is more tailored for
+# Java. For instance, namespaces will be presented as packages, qualified
+# scopes will look different, etc.
+
+OPTIMIZE_OUTPUT_JAVA = NO
+
+# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran
+# sources only. Doxygen will then generate output that is more tailored for
+# Fortran.
+
+OPTIMIZE_FOR_FORTRAN = YES
+
+# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL
+# sources. Doxygen will then generate output that is tailored for
+# VHDL.
+
+OPTIMIZE_OUTPUT_VHDL = NO
+
+# Doxygen selects the parser to use depending on the extension of the files it parses.
+# With this tag you can assign which parser to use for a given extension.
+# Doxygen has a built-in mapping, but you can override or extend it using this tag.
+# The format is ext=language, where ext is a file extension, and language is one of
+# the parsers supported by doxygen: IDL, Java, Javascript, C#, C, C++, D, PHP,
+# Objective-C, Python, Fortran, VHDL, C, C++. For instance to make doxygen treat
+# .inc files as Fortran files (default is PHP), and .f files as C (default is Fortran),
+# use: inc=Fortran f=C. Note that for custom extensions you also need to set FILE_PATTERNS otherwise the files are not read by doxygen.
+
+EXTENSION_MAPPING = f90=Fortran F90=Fortran f=Fortran F=Fortran
+
+# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want
+# to include (a tag file for) the STL sources as input, then you should
+# set this tag to YES in order to let doxygen match functions declarations and
+# definitions whose arguments contain STL classes (e.g. func(std::string); v.s.
+# func(std::string) {}). This also make the inheritance and collaboration
+# diagrams that involve STL classes more complete and accurate.
+
+BUILTIN_STL_SUPPORT = NO
+
+# If you use Microsoft's C++/CLI language, you should set this option to YES to
+# enable parsing support.
+
+CPP_CLI_SUPPORT = NO
+
+# Set the SIP_SUPPORT tag to YES if your project consists of sip sources only.
+# Doxygen will parse them like normal C++ but will assume all classes use public
+# instead of private inheritance when no explicit protection keyword is present.
+
+SIP_SUPPORT = NO
+
+# For Microsoft's IDL there are propget and propput attributes to indicate getter
+# and setter methods for a property. Setting this option to YES (the default)
+# will make doxygen to replace the get and set methods by a property in the
+# documentation. This will only work if the methods are indeed getting or
+# setting a simple type. If this is not the case, or you want to show the
+# methods anyway, you should set this option to NO.
+
+IDL_PROPERTY_SUPPORT = YES
+
+# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC
+# tag is set to YES, then doxygen will reuse the documentation of the first
+# member in the group (if any) for the other members of the group. By default
+# all members of a group must be documented explicitly.
+
+DISTRIBUTE_GROUP_DOC = NO
+
+# Set the SUBGROUPING tag to YES (the default) to allow class member groups of
+# the same type (for instance a group of public functions) to be put as a
+# subgroup of that type (e.g. under the Public Functions section). Set it to
+# NO to prevent subgrouping. Alternatively, this can be done per class using
+# the \nosubgrouping command.
+
+SUBGROUPING = YES
+
+# When TYPEDEF_HIDES_STRUCT is enabled, a typedef of a struct, union, or enum
+# is documented as struct, union, or enum with the name of the typedef. So
+# typedef struct TypeS {} TypeT, will appear in the documentation as a struct
+# with name TypeT. When disabled the typedef will appear as a member of a file,
+# namespace, or class. And the struct will be named TypeS. This can typically
+# be useful for C code in case the coding convention dictates that all compound
+# types are typedef'ed and only the typedef is referenced, never the tag name.
+
+TYPEDEF_HIDES_STRUCT = NO
+
+# The SYMBOL_CACHE_SIZE determines the size of the internal cache use to
+# determine which symbols to keep in memory and which to flush to disk.
+# When the cache is full, less often used symbols will be written to disk.
+# For small to medium size projects (<1000 input files) the default value is
+# probably good enough. For larger projects a too small cache size can cause
+# doxygen to be busy swapping symbols to and from disk most of the time
+# causing a significant performance penality.
+# If the system has enough physical memory increasing the cache will improve the
+# performance by keeping more symbols in memory. Note that the value works on
+# a logarithmic scale so increasing the size by one will rougly double the
+# memory usage. The cache size is given by this formula:
+# 2^(16+SYMBOL_CACHE_SIZE). The valid range is 0..9, the default is 0,
+# corresponding to a cache size of 2^16 = 65536 symbols
+
+SYMBOL_CACHE_SIZE = 0
+
+#---------------------------------------------------------------------------
+# Build related configuration options
+#---------------------------------------------------------------------------
+
+# If the EXTRACT_ALL tag is set to YES doxygen will assume all entities in
+# documentation are documented, even if no documentation was available.
+# Private class members and static file members will be hidden unless
+# the EXTRACT_PRIVATE and EXTRACT_STATIC tags are set to YES
+
+#EXTRACT_ALL = NO
+EXTRACT_ALL = YES
+
+# If the EXTRACT_PRIVATE tag is set to YES all private members of a class
+# will be included in the documentation.
+
+#EXTRACT_PRIVATE = NO
+EXTRACT_PRIVATE = YES
+
+# If the EXTRACT_STATIC tag is set to YES all static members of a file
+# will be included in the documentation.
+
+#EXTRACT_STATIC = NO
+EXTRACT_STATIC = YES
+
+# If the EXTRACT_LOCAL_CLASSES tag is set to YES classes (and structs)
+# defined locally in source files will be included in the documentation.
+# If set to NO only classes defined in header files are included.
+
+EXTRACT_LOCAL_CLASSES = YES
+
+# This flag is only useful for Objective-C code. When set to YES local
+# methods, which are defined in the implementation section but not in
+# the interface are included in the documentation.
+# If set to NO (the default) only methods in the interface are included.
+
+EXTRACT_LOCAL_METHODS = NO
+
+# If this flag is set to YES, the members of anonymous namespaces will be
+# extracted and appear in the documentation as a namespace called
+# 'anonymous_namespace{file}', where file will be replaced with the base
+# name of the file that contains the anonymous namespace. By default
+# anonymous namespace are hidden.
+
+EXTRACT_ANON_NSPACES = NO
+
+# If the HIDE_UNDOC_MEMBERS tag is set to YES, Doxygen will hide all
+# undocumented members of documented classes, files or namespaces.
+# If set to NO (the default) these members will be included in the
+# various overviews, but no documentation section is generated.
+# This option has no effect if EXTRACT_ALL is enabled.
+
+HIDE_UNDOC_MEMBERS = NO
+
+# If the HIDE_UNDOC_CLASSES tag is set to YES, Doxygen will hide all
+# undocumented classes that are normally visible in the class hierarchy.
+# If set to NO (the default) these classes will be included in the various
+# overviews. This option has no effect if EXTRACT_ALL is enabled.
+
+HIDE_UNDOC_CLASSES = NO
+
+# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, Doxygen will hide all
+# friend (class|struct|union) declarations.
+# If set to NO (the default) these declarations will be included in the
+# documentation.
+
+HIDE_FRIEND_COMPOUNDS = NO
+
+# If the HIDE_IN_BODY_DOCS tag is set to YES, Doxygen will hide any
+# documentation blocks found inside the body of a function.
+# If set to NO (the default) these blocks will be appended to the
+# function's detailed documentation block.
+
+HIDE_IN_BODY_DOCS = NO
+
+# The INTERNAL_DOCS tag determines if documentation
+# that is typed after a \internal command is included. If the tag is set
+# to NO (the default) then the documentation will be excluded.
+# Set it to YES to include the internal documentation.
+
+INTERNAL_DOCS = NO
+
+# If the CASE_SENSE_NAMES tag is set to NO then Doxygen will only generate
+# file names in lower-case letters. If set to YES upper-case letters are also
+# allowed. This is useful if you have classes or files whose names only differ
+# in case and if your file system supports case sensitive file names. Windows
+# and Mac users are advised to set this option to NO.
+
+CASE_SENSE_NAMES = YES
+
+# If the HIDE_SCOPE_NAMES tag is set to NO (the default) then Doxygen
+# will show members with their full class and namespace scopes in the
+# documentation. If set to YES the scope will be hidden.
+
+HIDE_SCOPE_NAMES = NO
+
+# If the SHOW_INCLUDE_FILES tag is set to YES (the default) then Doxygen
+# will put a list of the files that are included by a file in the documentation
+# of that file.
+
+SHOW_INCLUDE_FILES = YES
+
+# If the INLINE_INFO tag is set to YES (the default) then a tag [inline]
+# is inserted in the documentation for inline members.
+
+INLINE_INFO = YES
+
+# If the SORT_MEMBER_DOCS tag is set to YES (the default) then doxygen
+# will sort the (detailed) documentation of file and class members
+# alphabetically by member name. If set to NO the members will appear in
+# declaration order.
+
+SORT_MEMBER_DOCS = YES
+
+# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the
+# brief documentation of file, namespace and class members alphabetically
+# by member name. If set to NO (the default) the members will appear in
+# declaration order.
+
+SORT_BRIEF_DOCS = NO
+
+# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the
+# hierarchy of group names into alphabetical order. If set to NO (the default)
+# the group names will appear in their defined order.
+
+SORT_GROUP_NAMES = NO
+
+# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be
+# sorted by fully-qualified names, including namespaces. If set to
+# NO (the default), the class list will be sorted only by class name,
+# not including the namespace part.
+# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES.
+# Note: This option applies only to the class list, not to the
+# alphabetical list.
+
+SORT_BY_SCOPE_NAME = NO
+
+# The GENERATE_TODOLIST tag can be used to enable (YES) or
+# disable (NO) the todo list. This list is created by putting \todo
+# commands in the documentation.
+
+GENERATE_TODOLIST = YES
+
+# The GENERATE_TESTLIST tag can be used to enable (YES) or
+# disable (NO) the test list. This list is created by putting \test
+# commands in the documentation.
+
+GENERATE_TESTLIST = YES
+
+# The GENERATE_BUGLIST tag can be used to enable (YES) or
+# disable (NO) the bug list. This list is created by putting \bug
+# commands in the documentation.
+
+GENERATE_BUGLIST = YES
+
+# The GENERATE_DEPRECATEDLIST tag can be used to enable (YES) or
+# disable (NO) the deprecated list. This list is created by putting
+# \deprecated commands in the documentation.
+
+GENERATE_DEPRECATEDLIST= YES
+
+# The ENABLED_SECTIONS tag can be used to enable conditional
+# documentation sections, marked by \if sectionname ... \endif.
+
+ENABLED_SECTIONS =
+
+# The MAX_INITIALIZER_LINES tag determines the maximum number of lines
+# the initial value of a variable or define consists of for it to appear in
+# the documentation. If the initializer consists of more lines than specified
+# here it will be hidden. Use a value of 0 to hide initializers completely.
+# The appearance of the initializer of individual variables and defines in the
+# documentation can be controlled using \showinitializer or \hideinitializer
+# command in the documentation regardless of this setting.
+
+MAX_INITIALIZER_LINES = 30
+
+# Set the SHOW_USED_FILES tag to NO to disable the list of files generated
+# at the bottom of the documentation of classes and structs. If set to YES the
+# list will mention the files that were used to generate the documentation.
+
+SHOW_USED_FILES = YES
+
+# If the sources in your project are distributed over multiple directories
+# then setting the SHOW_DIRECTORIES tag to YES will show the directory hierarchy
+# in the documentation. The default is NO.
+
+SHOW_DIRECTORIES = NO
+
+# Set the SHOW_FILES tag to NO to disable the generation of the Files page.
+# This will remove the Files entry from the Quick Index and from the
+# Folder Tree View (if specified). The default is YES.
+
+SHOW_FILES = YES
+
+# Set the SHOW_NAMESPACES tag to NO to disable the generation of the
+# Namespaces page.
+# This will remove the Namespaces entry from the Quick Index
+# and from the Folder Tree View (if specified). The default is YES.
+
+SHOW_NAMESPACES = YES
+
+# The FILE_VERSION_FILTER tag can be used to specify a program or script that
+# doxygen should invoke to get the current version for each file (typically from
+# the version control system). Doxygen will invoke the program by executing (via
+# popen()) the command <command> <input-file>, where <command> is the value of
+# the FILE_VERSION_FILTER tag, and <input-file> is the name of an input file
+# provided by doxygen. Whatever the program writes to standard output
+# is used as the file version. See the manual for examples.
+
+FILE_VERSION_FILTER =
+
+# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed by
+# doxygen. The layout file controls the global structure of the generated output files
+# in an output format independent way. The create the layout file that represents
+# doxygen's defaults, run doxygen with the -l option. You can optionally specify a
+# file name after the option, if omitted DoxygenLayout.xml will be used as the name
+# of the layout file.
+
+LAYOUT_FILE =
+
+#---------------------------------------------------------------------------
+# configuration options related to warning and progress messages
+#---------------------------------------------------------------------------
+
+# The QUIET tag can be used to turn on/off the messages that are generated
+# by doxygen. Possible values are YES and NO. If left blank NO is used.
+
+QUIET = NO
+
+# The WARNINGS tag can be used to turn on/off the warning messages that are
+# generated by doxygen. Possible values are YES and NO. If left blank
+# NO is used.
+
+WARNINGS = YES
+
+# If WARN_IF_UNDOCUMENTED is set to YES, then doxygen will generate warnings
+# for undocumented members. If EXTRACT_ALL is set to YES then this flag will
+# automatically be disabled.
+
+WARN_IF_UNDOCUMENTED = YES
+
+# If WARN_IF_DOC_ERROR is set to YES, doxygen will generate warnings for
+# potential errors in the documentation, such as not documenting some
+# parameters in a documented function, or documenting parameters that
+# don't exist or using markup commands wrongly.
+
+WARN_IF_DOC_ERROR = YES
+
+# This WARN_NO_PARAMDOC option can be abled to get warnings for
+# functions that are documented, but have no documentation for their parameters
+# or return value. If set to NO (the default) doxygen will only warn about
+# wrong or incomplete parameter documentation, but not about the absence of
+# documentation.
+
+WARN_NO_PARAMDOC = NO
+
+# The WARN_FORMAT tag determines the format of the warning messages that
+# doxygen can produce. The string should contain the $file, $line, and $text
+# tags, which will be replaced by the file and line number from which the
+# warning originated and the warning text. Optionally the format may contain
+# $version, which will be replaced by the version of the file (if it could
+# be obtained via FILE_VERSION_FILTER)
+
+WARN_FORMAT = "$file:$line: $text"
+
+# The WARN_LOGFILE tag can be used to specify a file to which warning
+# and error messages should be written. If left blank the output is written
+# to stderr.
+
+WARN_LOGFILE =
+
+#---------------------------------------------------------------------------
+# configuration options related to the input files
+#---------------------------------------------------------------------------
+
+# The INPUT tag can be used to specify the files and/or directories that contain
+# documented source files. You may enter file names like "myfile.cpp" or
+# directories like "/usr/src/myproject". Separate the files or directories
+# with spaces.
+
+INPUT = "../../src" "../../test/src" "../../example/src/" "ext_doc"
+
+# This tag can be used to specify the character encoding of the source files
+# that doxygen parses. Internally doxygen uses the UTF-8 encoding, which is
+# also the default input encoding. Doxygen uses libiconv (or the iconv built
+# into libc) for the transcoding. See http://www.gnu.org/software/libiconv for
+# the list of possible encodings.
+
+INPUT_ENCODING = UTF-8
+
+# If the value of the INPUT tag contains directories, you can use the
+# FILE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp
+# and *.h) to filter out the source-files in the directories. If left
+# blank the following patterns are tested:
+# *.c *.cc *.cxx *.cpp *.c++ *.java *.ii *.ixx *.ipp *.i++ *.inl *.h *.hh *.hxx
+# *.hpp *.h++ *.idl *.odl *.cs *.php *.php3 *.inc *.m *.mm *.py *.f90
+
+FILE_PATTERNS = *.f90 *.F90 *.F *.f
+
+# The RECURSIVE tag can be used to turn specify whether or not subdirectories
+# should be searched for input files as well. Possible values are YES and NO.
+# If left blank NO is used.
+
+RECURSIVE = YES
+
+# The EXCLUDE tag can be used to specify files and/or directories that should
+# excluded from the INPUT source files. This way you can easily exclude a
+# subdirectory from a directory tree whose root is specified with the INPUT tag.
+
+EXCLUDE =
+
+# The EXCLUDE_SYMLINKS tag can be used select whether or not files or
+# directories that are symbolic links (a Unix filesystem feature) are excluded
+# from the input.
+
+EXCLUDE_SYMLINKS = NO
+
+# If the value of the INPUT tag contains directories, you can use the
+# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude
+# certain files from those directories. Note that the wildcards are matched
+# against the file with absolute path, so to exclude all test directories
+# for example use the pattern */test/*
+
+EXCLUDE_PATTERNS = */~*
+
+# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names
+# (namespaces, classes, functions, etc.) that should be excluded from the
+# output. The symbol name can be a fully qualified name, a word, or if the
+# wildcard * is used, a substring. Examples: ANamespace, AClass,
+# AClass::ANamespace, ANamespace::*Test
+
+EXCLUDE_SYMBOLS =
+
+# The EXAMPLE_PATH tag can be used to specify one or more files or
+# directories that contain example code fragments that are included (see
+# the \include command).
+
+EXAMPLE_PATH =
+
+# If the value of the EXAMPLE_PATH tag contains directories, you can use the
+# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp
+# and *.h) to filter out the source-files in the directories. If left
+# blank all files are included.
+
+EXAMPLE_PATTERNS =
+
+# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be
+# searched for input files to be used with the \include or \dontinclude
+# commands irrespective of the value of the RECURSIVE tag.
+# Possible values are YES and NO. If left blank NO is used.
+
+EXAMPLE_RECURSIVE = NO
+
+# The IMAGE_PATH tag can be used to specify one or more files or
+# directories that contain image that are included in the documentation (see
+# the \image command).
+
+IMAGE_PATH = ./images
+
+# The INPUT_FILTER tag can be used to specify a program that doxygen should
+# invoke to filter for each input file. Doxygen will invoke the filter program
+# by executing (via popen()) the command <filter> <input-file>, where <filter>
+# is the value of the INPUT_FILTER tag, and <input-file> is the name of an
+# input file. Doxygen will then use the output that the filter program writes
+# to standard output.
+# If FILTER_PATTERNS is specified, this tag will be
+# ignored.
+
+INPUT_FILTER =
+
+# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern
+# basis.
+# Doxygen will compare the file name with each pattern and apply the
+# filter if there is a match.
+# The filters are a list of the form:
+# pattern=filter (like *.cpp=my_cpp_filter). See INPUT_FILTER for further
+# info on how filters are used. If FILTER_PATTERNS is empty, INPUT_FILTER
+# is applied to all files.
+
+FILTER_PATTERNS =
+
+# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using
+# INPUT_FILTER) will be used to filter the input files when producing source
+# files to browse (i.e. when SOURCE_BROWSER is set to YES).
+
+FILTER_SOURCE_FILES = NO
+
+#---------------------------------------------------------------------------
+# configuration options related to source browsing
+#---------------------------------------------------------------------------
+
+# If the SOURCE_BROWSER tag is set to YES then a list of source files will
+# be generated. Documented entities will be cross-referenced with these sources.
+# Note: To get rid of all source code in the generated output, make sure also
+# VERBATIM_HEADERS is set to NO.
+
+SOURCE_BROWSER = YES
+
+# Setting the INLINE_SOURCES tag to YES will include the body
+# of functions and classes directly in the documentation.
+
+INLINE_SOURCES = NO
+
+# Setting the STRIP_CODE_COMMENTS tag to YES (the default) will instruct
+# doxygen to hide any special comment blocks from generated source code
+# fragments. Normal C and C++ comments will always remain visible.
+
+STRIP_CODE_COMMENTS = YES
+
+# If the REFERENCED_BY_RELATION tag is set to YES
+# then for each documented function all documented
+# functions referencing it will be listed.
+
+REFERENCED_BY_RELATION = YES
+
+# If the REFERENCES_RELATION tag is set to YES
+# then for each documented function all documented entities
+# called/used by that function will be listed.
+
+REFERENCES_RELATION = YES
+
+# If the REFERENCES_LINK_SOURCE tag is set to YES (the default)
+# and SOURCE_BROWSER tag is set to YES, then the hyperlinks from
+# functions in REFERENCES_RELATION and REFERENCED_BY_RELATION lists will
+# link to the source code.
+# Otherwise they will link to the documentation.
+
+REFERENCES_LINK_SOURCE = YES
+
+# If the USE_HTAGS tag is set to YES then the references to source code
+# will point to the HTML generated by the htags(1) tool instead of doxygen
+# built-in source browser. The htags tool is part of GNU's global source
+# tagging system (see http://www.gnu.org/software/global/global.html). You
+# will need version 4.8.6 or higher.
+
+USE_HTAGS = NO
+
+# If the VERBATIM_HEADERS tag is set to YES (the default) then Doxygen
+# will generate a verbatim copy of the header file for each class for
+# which an include is specified. Set to NO to disable this.
+
+VERBATIM_HEADERS = YES
+
+#---------------------------------------------------------------------------
+# configuration options related to the alphabetical class index
+#---------------------------------------------------------------------------
+
+# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index
+# of all compounds will be generated. Enable this if the project
+# contains a lot of classes, structs, unions or interfaces.
+
+ALPHABETICAL_INDEX = YES
+
+# If the alphabetical index is enabled (see ALPHABETICAL_INDEX) then
+# the COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns
+# in which this list will be split (can be a number in the range [1..20])
+
+COLS_IN_ALPHA_INDEX = 5
+
+# In case all classes in a project start with a common prefix, all
+# classes will be put under the same header in the alphabetical index.
+# The IGNORE_PREFIX tag can be used to specify one or more prefixes that
+# should be ignored while generating the index headers.
+
+IGNORE_PREFIX =
+
+#---------------------------------------------------------------------------
+# configuration options related to the HTML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_HTML tag is set to YES (the default) Doxygen will
+# generate HTML output.
+
+GENERATE_HTML = YES
+
+# The HTML_OUTPUT tag is used to specify where the HTML docs will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be
+# put in front of it. If left blank `html' will be used as the default path.
+
+HTML_OUTPUT = html
+
+# The HTML_FILE_EXTENSION tag can be used to specify the file extension for
+# each generated HTML page (for example: .htm,.php,.asp). If it is left blank
+# doxygen will generate files with .html extension.
+
+HTML_FILE_EXTENSION = .html
+
+# The HTML_HEADER tag can be used to specify a personal HTML header for
+# each generated HTML page. If it is left blank doxygen will generate a
+# standard header.
+
+HTML_HEADER =
+
+# If the HTML_FOOTER_DESCRIPTION tag is set to YES, Doxygen will
+# add generated date, project name and doxygen version to HTML footer.
+
+HTML_FOOTER_DESCRIPTION= NO
+
+# The HTML_FOOTER tag can be used to specify a personal HTML footer for
+# each generated HTML page. If it is left blank doxygen will generate a
+# standard footer.
+
+HTML_FOOTER =
+
+# The HTML_STYLESHEET tag can be used to specify a user-defined cascading
+# style sheet that is used by each HTML page. It can be used to
+# fine-tune the look of the HTML output. If the tag is left blank doxygen
+# will generate a default style sheet. Note that doxygen will try to copy
+# the style sheet file to the HTML output directory, so don't put your own
+# stylesheet in the HTML output directory as well, or it will be erased!
+
+HTML_STYLESHEET =
+
+# If the HTML_ALIGN_MEMBERS tag is set to YES, the members of classes,
+# files or namespaces will be aligned in HTML using tables. If set to
+# NO a bullet list will be used.
+
+HTML_ALIGN_MEMBERS = YES
+
+# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML
+# documentation will contain sections that can be hidden and shown after the
+# page has loaded. For this to work a browser that supports
+# JavaScript and DHTML is required (for instance Mozilla 1.0+, Firefox
+# Netscape 6.0+, Internet explorer 5.0+, Konqueror, or Safari).
+
+HTML_DYNAMIC_SECTIONS = NO
+
+# If the GENERATE_DOCSET tag is set to YES, additional index files
+# will be generated that can be used as input for Apple's Xcode 3
+# integrated development environment, introduced with OSX 10.5 (Leopard).
+# To create a documentation set, doxygen will generate a Makefile in the
+# HTML output directory. Running make will produce the docset in that
+# directory and running "make install" will install the docset in
+# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find
+# it at startup.
+# See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html for more information.
+
+GENERATE_DOCSET = NO
+
+# When GENERATE_DOCSET tag is set to YES, this tag determines the name of the
+# feed. A documentation feed provides an umbrella under which multiple
+# documentation sets from a single provider (such as a company or product suite)
+# can be grouped.
+
+DOCSET_FEEDNAME = "Doxygen generated docs"
+
+# When GENERATE_DOCSET tag is set to YES, this tag specifies a string that
+# should uniquely identify the documentation set bundle. This should be a
+# reverse domain-name style string, e.g. com.mycompany.MyDocSet. Doxygen
+# will append .docset to the name.
+
+DOCSET_BUNDLE_ID = org.doxygen.Project
+
+# If the GENERATE_HTMLHELP tag is set to YES, additional index files
+# will be generated that can be used as input for tools like the
+# Microsoft HTML help workshop to generate a compiled HTML help file (.chm)
+# of the generated HTML documentation.
+
+GENERATE_HTMLHELP = NO
+
+# If the GENERATE_HTMLHELP tag is set to YES, the CHM_FILE tag can
+# be used to specify the file name of the resulting .chm file. You
+# can add a path in front of the file if the result should not be
+# written to the html output directory.
+
+CHM_FILE =
+
+# If the GENERATE_HTMLHELP tag is set to YES, the HHC_LOCATION tag can
+# be used to specify the location (absolute path including file name) of
+# the HTML help compiler (hhc.exe). If non-empty doxygen will try to run
+# the HTML help compiler on the generated index.hhp.
+
+HHC_LOCATION =
+
+# If the GENERATE_HTMLHELP tag is set to YES, the GENERATE_CHI flag
+# controls if a separate .chi index file is generated (YES) or that
+# it should be included in the master .chm file (NO).
+
+GENERATE_CHI = NO
+
+# If the GENERATE_HTMLHELP tag is set to YES, the CHM_INDEX_ENCODING
+# is used to encode HtmlHelp index (hhk), content (hhc) and project file
+# content.
+
+CHM_INDEX_ENCODING =
+
+# If the GENERATE_HTMLHELP tag is set to YES, the BINARY_TOC flag
+# controls whether a binary table of contents is generated (YES) or a
+# normal table of contents (NO) in the .chm file.
+
+BINARY_TOC = NO
+
+# The TOC_EXPAND flag can be set to YES to add extra items for group members
+# to the contents of the HTML help documentation and to the tree view.
+
+TOC_EXPAND = NO
+
+# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and QHP_VIRTUAL_FOLDER
+# are set, an additional index file will be generated that can be used as input for
+# Qt's qhelpgenerator to generate a Qt Compressed Help (.qch) of the generated
+# HTML documentation.
+
+GENERATE_QHP = NO
+
+# If the QHG_LOCATION tag is specified, the QCH_FILE tag can
+# be used to specify the file name of the resulting .qch file.
+# The path specified is relative to the HTML output folder.
+
+QCH_FILE =
+
+# The QHP_NAMESPACE tag specifies the namespace to use when generating
+# Qt Help Project output. For more information please see
+# http://doc.trolltech.com/qthelpproject.html#namespace
+
+QHP_NAMESPACE =
+
+# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating
+# Qt Help Project output. For more information please see
+# http://doc.trolltech.com/qthelpproject.html#virtual-folders
+
+QHP_VIRTUAL_FOLDER = doc
+
+# If QHP_CUST_FILTER_NAME is set, it specifies the name of a custom filter to add.
+# For more information please see
+# http://doc.trolltech.com/qthelpproject.html#custom-filters
+
+QHP_CUST_FILTER_NAME =
+
+# The QHP_CUST_FILT_ATTRS tag specifies the list of the attributes of the custom filter to add.For more information please see
+# <a href="http://doc.trolltech.com/qthelpproject.html#custom-filters">Qt Help Project / Custom Filters</a>.
+
+QHP_CUST_FILTER_ATTRS =
+
+# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this project's
+# filter section matches.
+# <a href="http://doc.trolltech.com/qthelpproject.html#filter-attributes">Qt Help Project / Filter Attributes</a>.
+
+QHP_SECT_FILTER_ATTRS =
+
+# If the GENERATE_QHP tag is set to YES, the QHG_LOCATION tag can
+# be used to specify the location of Qt's qhelpgenerator.
+# If non-empty doxygen will try to run qhelpgenerator on the generated
+# .qhp file.
+
+QHG_LOCATION =
+
+# The DISABLE_INDEX tag can be used to turn on/off the condensed index at
+# top of each HTML page. The value NO (the default) enables the index and
+# the value YES disables it.
+
+DISABLE_INDEX = NO
+
+# This tag can be used to set the number of enum values (range [1..20])
+# that doxygen will group on one line in the generated HTML documentation.
+
+ENUM_VALUES_PER_LINE = 4
+
+# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index
+# structure should be generated to display hierarchical information.
+# If the tag value is set to FRAME, a side panel will be generated
+# containing a tree-like index structure (just like the one that
+# is generated for HTML Help). For this to work a browser that supports
+# JavaScript, DHTML, CSS and frames is required (for instance Mozilla 1.0+,
+# Netscape 6.0+, Internet explorer 5.0+, or Konqueror). Windows users are
+# probably better off using the HTML help feature. Other possible values
+# for this tag are: HIERARCHIES, which will generate the Groups, Directories,
+# and Class Hierarchy pages using a tree view instead of an ordered list;
+# ALL, which combines the behavior of FRAME and HIERARCHIES; and NONE, which
+# disables this behavior completely. For backwards compatibility with previous
+# releases of Doxygen, the values YES and NO are equivalent to FRAME and NONE
+# respectively.
+
+GENERATE_TREEVIEW = YES
+
+# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be
+# used to set the initial width (in pixels) of the frame in which the tree
+# is shown.
+
+TREEVIEW_WIDTH = 250
+
+# Use this tag to change the font size of Latex formulas included
+# as images in the HTML documentation. The default is 10. Note that
+# when you change the font size after a successful doxygen run you need
+# to manually remove any form_*.png images from the HTML output directory
+# to force them to be regenerated.
+
+FORMULA_FONTSIZE = 10
+
+#---------------------------------------------------------------------------
+# configuration options related to the LaTeX output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_LATEX tag is set to YES (the default) Doxygen will
+# generate Latex output.
+
+GENERATE_LATEX = YES
+
+# The LATEX_OUTPUT tag is used to specify where the LaTeX docs will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be
+# put in front of it. If left blank `latex' will be used as the default path.
+
+LATEX_OUTPUT = latex
+
+# The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be
+# invoked. If left blank `latex' will be used as the default command name.
+
+LATEX_CMD_NAME = latex
+
+# The MAKEINDEX_CMD_NAME tag can be used to specify the command name to
+# generate index for LaTeX. If left blank `makeindex' will be used as the
+# default command name.
+
+MAKEINDEX_CMD_NAME = makeindex
+
+# If the COMPACT_LATEX tag is set to YES Doxygen generates more compact
+# LaTeX documents. This may be useful for small projects and may help to
+# save some trees in general.
+
+COMPACT_LATEX = NO
+
+# The PAPER_TYPE tag can be used to set the paper type that is used
+# by the printer. Possible values are: a4, a4wide, letter, legal and
+# executive. If left blank a4wide will be used.
+
+PAPER_TYPE = a4wide
+
+# The EXTRA_PACKAGES tag can be to specify one or more names of LaTeX
+# packages that should be included in the LaTeX output.
+
+EXTRA_PACKAGES =
+
+# The LATEX_HEADER tag can be used to specify a personal LaTeX header for
+# the generated latex document. The header should contain everything until
+# the first chapter. If it is left blank doxygen will generate a
+# standard header. Notice: only use this tag if you know what you are doing!
+
+LATEX_HEADER =
+
+# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated
+# is prepared for conversion to pdf (using ps2pdf). The pdf file will
+# contain links (just like the HTML output) instead of page references
+# This makes the output suitable for online browsing using a pdf viewer.
+
+PDF_HYPERLINKS = YES
+
+# If the USE_PDFLATEX tag is set to YES, pdflatex will be used instead of
+# plain latex in the generated Makefile. Set this option to YES to get a
+# higher quality PDF documentation.
+
+USE_PDFLATEX = YES
+
+# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \\batchmode.
+# command to the generated LaTeX files. This will instruct LaTeX to keep
+# running if errors occur, instead of asking the user for help.
+# This option is also used when generating formulas in HTML.
+
+LATEX_BATCHMODE = NO
+
+# If LATEX_HIDE_INDICES is set to YES then doxygen will not
+# include the index chapters (such as File Index, Compound Index, etc.)
+# in the output.
+
+LATEX_HIDE_INDICES = NO
+
+# If LATEX_SOURCE_CODE is set to YES then doxygen will include source code with syntax highlighting in the LaTeX output. Note that which sources are shown also depends on other settings such as SOURCE_BROWSER.
+
+LATEX_SOURCE_CODE = YES
+
+#---------------------------------------------------------------------------
+# configuration options related to the RTF output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_RTF tag is set to YES Doxygen will generate RTF output
+# The RTF output is optimized for Word 97 and may not look very pretty with
+# other RTF readers or editors.
+
+GENERATE_RTF = NO
+
+# The RTF_OUTPUT tag is used to specify where the RTF docs will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be
+# put in front of it. If left blank `rtf' will be used as the default path.
+
+RTF_OUTPUT = rtf
+
+# If the COMPACT_RTF tag is set to YES Doxygen generates more compact
+# RTF documents. This may be useful for small projects and may help to
+# save some trees in general.
+
+COMPACT_RTF = NO
+
+# If the RTF_HYPERLINKS tag is set to YES, the RTF that is generated
+# will contain hyperlink fields. The RTF file will
+# contain links (just like the HTML output) instead of page references.
+# This makes the output suitable for online browsing using WORD or other
+# programs which support those fields.
+# Note: wordpad (write) and others do not support links.
+
+RTF_HYPERLINKS = NO
+
+# Load stylesheet definitions from file. Syntax is similar to doxygen's
+# config file, i.e. a series of assignments. You only have to provide
+# replacements, missing definitions are set to their default value.
+
+RTF_STYLESHEET_FILE =
+
+# Set optional variables used in the generation of an rtf document.
+# Syntax is similar to doxygen's config file.
+
+RTF_EXTENSIONS_FILE =
+
+#---------------------------------------------------------------------------
+# configuration options related to the man page output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_MAN tag is set to YES (the default) Doxygen will
+# generate man pages
+
+GENERATE_MAN = NO
+
+# The MAN_OUTPUT tag is used to specify where the man pages will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be
+# put in front of it. If left blank `man' will be used as the default path.
+
+MAN_OUTPUT = man
+
+# The MAN_EXTENSION tag determines the extension that is added to
+# the generated man pages (default is the subroutine's section .3)
+
+MAN_EXTENSION = .3
+
+# If the MAN_LINKS tag is set to YES and Doxygen generates man output,
+# then it will generate one additional man file for each entity
+# documented in the real man page(s). These additional files
+# only source the real man page, but without them the man command
+# would be unable to find the correct page. The default is NO.
+
+MAN_LINKS = NO
+
+#---------------------------------------------------------------------------
+# configuration options related to the XML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_XML tag is set to YES Doxygen will
+# generate an XML file that captures the structure of
+# the code including all documentation.
+
+GENERATE_XML = NO
+
+# The XML_OUTPUT tag is used to specify where the XML pages will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be
+# put in front of it. If left blank `xml' will be used as the default path.
+
+XML_OUTPUT = xml
+
+# The XML_SCHEMA tag can be used to specify an XML schema,
+# which can be used by a validating XML parser to check the
+# syntax of the XML files.
+
+XML_SCHEMA =
+
+# The XML_DTD tag can be used to specify an XML DTD,
+# which can be used by a validating XML parser to check the
+# syntax of the XML files.
+
+XML_DTD =
+
+# If the XML_PROGRAMLISTING tag is set to YES Doxygen will
+# dump the program listings (including syntax highlighting
+# and cross-referencing information) to the XML output. Note that
+# enabling this will significantly increase the size of the XML output.
+
+XML_PROGRAMLISTING = YES
+
+#---------------------------------------------------------------------------
+# configuration options for the AutoGen Definitions output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_AUTOGEN_DEF tag is set to YES Doxygen will
+# generate an AutoGen Definitions (see autogen.sf.net) file
+# that captures the structure of the code including all
+# documentation. Note that this feature is still experimental
+# and incomplete at the moment.
+
+GENERATE_AUTOGEN_DEF = NO
+
+#---------------------------------------------------------------------------
+# configuration options related to the Perl module output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_PERLMOD tag is set to YES Doxygen will
+# generate a Perl module file that captures the structure of
+# the code including all documentation. Note that this
+# feature is still experimental and incomplete at the
+# moment.
+
+GENERATE_PERLMOD = NO
+
+# If the PERLMOD_LATEX tag is set to YES Doxygen will generate
+# the necessary Makefile rules, Perl scripts and LaTeX code to be able
+# to generate PDF and DVI output from the Perl module output.
+
+PERLMOD_LATEX = NO
+
+# If the PERLMOD_PRETTY tag is set to YES the Perl module output will be
+# nicely formatted so it can be parsed by a human reader.
+# This is useful
+# if you want to understand what is going on.
+# On the other hand, if this
+# tag is set to NO the size of the Perl module output will be much smaller
+# and Perl will parse it just the same.
+
+PERLMOD_PRETTY = YES
+
+# The names of the make variables in the generated doxyrules.make file
+# are prefixed with the string contained in PERLMOD_MAKEVAR_PREFIX.
+# This is useful so different doxyrules.make files included by the same
+# Makefile don't overwrite each other's variables.
+
+PERLMOD_MAKEVAR_PREFIX =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the preprocessor
+#---------------------------------------------------------------------------
+
+# If the ENABLE_PREPROCESSING tag is set to YES (the default) Doxygen will
+# evaluate all C-preprocessor directives found in the sources and include
+# files.
+
+ENABLE_PREPROCESSING = YES
+
+# If the MACRO_EXPANSION tag is set to YES Doxygen will expand all macro
+# names in the source code. If set to NO (the default) only conditional
+# compilation will be performed. Macro expansion can be done in a controlled
+# way by setting EXPAND_ONLY_PREDEF to YES.
+
+MACRO_EXPANSION = NO
+
+# If the EXPAND_ONLY_PREDEF and MACRO_EXPANSION tags are both set to YES
+# then the macro expansion is limited to the macros specified with the
+# PREDEFINED and EXPAND_AS_DEFINED tags.
+
+EXPAND_ONLY_PREDEF = NO
+
+# If the SEARCH_INCLUDES tag is set to YES (the default) the includes files
+# in the INCLUDE_PATH (see below) will be search if a #include is found.
+
+SEARCH_INCLUDES = YES
+
+# The INCLUDE_PATH tag can be used to specify one or more directories that
+# contain include files that are not input files but should be processed by
+# the preprocessor.
+
+INCLUDE_PATH =
+
+# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard
+# patterns (like *.h and *.hpp) to filter out the header-files in the
+# directories. If left blank, the patterns specified with FILE_PATTERNS will
+# be used.
+
+INCLUDE_FILE_PATTERNS =
+
+# The PREDEFINED tag can be used to specify one or more macro names that
+# are defined before the preprocessor is started (similar to the -D option of
+# gcc). The argument of the tag is a list of macros of the form: name
+# or name=definition (no spaces). If the definition and the = are
+# omitted =1 is assumed. To prevent a macro definition from being
+# undefined via #undef or recursively expanded use the := operator
+# instead of the = operator.
+
+PREDEFINED =
+
+# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then
+# this tag can be used to specify a list of macro names that should be expanded.
+# The macro definition that is found in the sources will be used.
+# Use the PREDEFINED tag if you want to use a different macro definition.
+
+EXPAND_AS_DEFINED =
+
+# If the SKIP_FUNCTION_MACROS tag is set to YES (the default) then
+# doxygen's preprocessor will remove all function-like macros that are alone
+# on a line, have an all uppercase name, and do not end with a semicolon. Such
+# function macros are typically used for boiler-plate code, and will confuse
+# the parser if not removed.
+
+SKIP_FUNCTION_MACROS = YES
+
+#---------------------------------------------------------------------------
+# Configuration::additions related to external references
+#---------------------------------------------------------------------------
+
+# The TAGFILES option can be used to specify one or more tagfiles.
+# Optionally an initial location of the external documentation
+# can be added for each tagfile. The format of a tag file without
+# this location is as follows:
+#
+# TAGFILES = file1 file2 ...
+# Adding location for the tag files is done as follows:
+#
+# TAGFILES = file1=loc1 "file2 = loc2" ...
+# where "loc1" and "loc2" can be relative or absolute paths or
+# URLs. If a location is present for each tag, the installdox tool
+# does not have to be run to correct the links.
+# Note that each tag file must have a unique name
+# (where the name does NOT include the path)
+# If a tag file is not located in the directory in which doxygen
+# is run, you must also specify the path to the tagfile here.
+
+TAGFILES =
+
+# When a file name is specified after GENERATE_TAGFILE, doxygen will create
+# a tag file that is based on the input files it reads.
+
+GENERATE_TAGFILE =
+
+# If the ALLEXTERNALS tag is set to YES all external classes will be listed
+# in the class index. If set to NO only the inherited external classes
+# will be listed.
+
+ALLEXTERNALS = NO
+
+# If the EXTERNAL_GROUPS tag is set to YES all external groups will be listed
+# in the modules index. If set to NO, only the current project's groups will
+# be listed.
+
+EXTERNAL_GROUPS = YES
+
+# The PERL_PATH should be the absolute path and name of the perl script
+# interpreter (i.e. the result of `which perl').
+
+PERL_PATH = /usr/bin/perl
+
+#---------------------------------------------------------------------------
+# Configuration options related to the dot tool
+#---------------------------------------------------------------------------
+
+# If the CLASS_DIAGRAMS tag is set to YES (the default) Doxygen will
+# generate a inheritance diagram (in HTML, RTF and LaTeX) for classes with base
+# or super classes. Setting the tag to NO turns the diagrams off. Note that
+# this option is superseded by the HAVE_DOT option below. This is only a
+# fallback. It is recommended to install and use dot, since it yields more
+# powerful graphs.
+
+CLASS_DIAGRAMS = YES
+
+# You can define message sequence charts within doxygen comments using the \msc
+# command. Doxygen will then run the mscgen tool (see
+# http://www.mcternan.me.uk/mscgen/) to produce the chart and insert it in the
+# documentation. The MSCGEN_PATH tag allows you to specify the directory where
+# the mscgen tool resides. If left empty the tool is assumed to be found in the
+# default search path.
+
+MSCGEN_PATH =
+
+# If set to YES, the inheritance and collaboration graphs will hide
+# inheritance and usage relations if the target is undocumented
+# or is not a class.
+
+HIDE_UNDOC_RELATIONS = YES
+
+# If you set the HAVE_DOT tag to YES then doxygen will assume the dot tool is
+# available from the path. This tool is part of Graphviz, a graph visualization
+# toolkit from AT&T and Lucent Bell Labs. The other options in this section
+# have no effect if this option is set to NO (the default)
+
+#HAVE_DOT = NO
+HAVE_DOT = YES
+
+# By default doxygen will write a font called FreeSans.ttf to the output
+# directory and reference it in all dot files that doxygen generates. This
+# font does not include all possible unicode characters however, so when you need
+# these (or just want a differently looking font) you can specify the font name
+# using DOT_FONTNAME. You need need to make sure dot is able to find the font,
+# which can be done by putting it in a standard location or by setting the
+# DOTFONTPATH environment variable or by setting DOT_FONTPATH to the directory
+# containing the font.
+
+DOT_FONTNAME = FreeSans
+
+# The DOT_FONTSIZE tag can be used to set the size of the font of dot graphs.
+# The default size is 10pt.
+
+DOT_FONTSIZE = 10
+
+# By default doxygen will tell dot to use the output directory to look for the
+# FreeSans.ttf font (which doxygen will put there itself). If you specify a
+# different font using DOT_FONTNAME you can set the path where dot
+# can find it using this tag.
+
+DOT_FONTPATH =
+
+# If the CLASS_GRAPH and HAVE_DOT tags are set to YES then doxygen
+# will generate a graph for each documented class showing the direct and
+# indirect inheritance relations. Setting this tag to YES will force the
+# the CLASS_DIAGRAMS tag to NO.
+
+CLASS_GRAPH = YES
+
+# If the COLLABORATION_GRAPH and HAVE_DOT tags are set to YES then doxygen
+# will generate a graph for each documented class showing the direct and
+# indirect implementation dependencies (inheritance, containment, and
+# class references variables) of the class with other documented classes.
+
+COLLABORATION_GRAPH = YES
+
+# If the GROUP_GRAPHS and HAVE_DOT tags are set to YES then doxygen
+# will generate a graph for groups, showing the direct groups dependencies
+
+GROUP_GRAPHS = YES
+
+# If the UML_LOOK tag is set to YES doxygen will generate inheritance and
+# collaboration diagrams in a style similar to the OMG's Unified Modeling
+# Language.
+
+UML_LOOK = NO
+
+# If set to YES, the inheritance and collaboration graphs will show the
+# relations between templates and their instances.
+
+TEMPLATE_RELATIONS = NO
+
+# If the ENABLE_PREPROCESSING, SEARCH_INCLUDES, INCLUDE_GRAPH, and HAVE_DOT
+# tags are set to YES then doxygen will generate a graph for each documented
+# file showing the direct and indirect include dependencies of the file with
+# other documented files.
+
+INCLUDE_GRAPH = YES
+
+# If the ENABLE_PREPROCESSING, SEARCH_INCLUDES, INCLUDED_BY_GRAPH, and
+# HAVE_DOT tags are set to YES then doxygen will generate a graph for each
+# documented header file showing the documented files that directly or
+# indirectly include this file.
+
+INCLUDED_BY_GRAPH = YES
+
+# If the CALL_GRAPH and HAVE_DOT options are set to YES then
+# doxygen will generate a call dependency graph for every global function
+# or class method. Note that enabling this option will significantly increase
+# the time of a run. So in most cases it will be better to enable call graphs
+# for selected functions only using the \callgraph command.
+
+#CALL_GRAPH = NO
+CALL_GRAPH = YES
+
+# If the CALLER_GRAPH and HAVE_DOT tags are set to YES then
+# doxygen will generate a caller dependency graph for every global function
+# or class method. Note that enabling this option will significantly increase
+# the time of a run. So in most cases it will be better to enable caller
+# graphs for selected functions only using the \callergraph command.
+
+#CALLER_GRAPH = NO
+CALLER_GRAPH = YES
+
+# If the GRAPHICAL_HIERARCHY and HAVE_DOT tags are set to YES then doxygen
+# will graphical hierarchy of all classes instead of a textual one.
+
+GRAPHICAL_HIERARCHY = YES
+
+# If the DIRECTORY_GRAPH, SHOW_DIRECTORIES and HAVE_DOT tags are set to YES
+# then doxygen will show the dependencies a directory has on other directories
+# in a graphical way. The dependency relations are determined by the #include
+# relations between the files in the directories.
+
+DIRECTORY_GRAPH = YES
+
+# The DOT_IMAGE_FORMAT tag can be used to set the image format of the images
+# generated by dot. Possible values are png, jpg, or gif
+# If left blank png will be used.
+
+DOT_IMAGE_FORMAT = png
+
+# The tag DOT_PATH can be used to specify the path where the dot tool can be
+# found. If left blank, it is assumed the dot tool can be found in the path.
+
+DOT_PATH =
+
+# The DOTFILE_DIRS tag can be used to specify one or more directories that
+# contain dot files that are included in the documentation (see the
+# \dotfile command).
+
+DOTFILE_DIRS =
+
+# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of
+# nodes that will be shown in the graph. If the number of nodes in a graph
+# becomes larger than this value, doxygen will truncate the graph, which is
+# visualized by representing a node as a red box. Note that doxygen if the
+# number of direct children of the root node in a graph is already larger than
+# DOT_GRAPH_MAX_NODES then the graph will not be shown at all. Also note
+# that the size of a graph can be further restricted by MAX_DOT_GRAPH_DEPTH.
+
+DOT_GRAPH_MAX_NODES = 50
+
+# The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the
+# graphs generated by dot. A depth value of 3 means that only nodes reachable
+# from the root by following a path via at most 3 edges will be shown. Nodes
+# that lay further from the root node will be omitted. Note that setting this
+# option to 1 or 2 may greatly reduce the computation time needed for large
+# code bases. Also note that the size of a graph can be further restricted by
+# DOT_GRAPH_MAX_NODES. Using a depth of 0 means no depth restriction.
+
+MAX_DOT_GRAPH_DEPTH = 0
+
+# Set the DOT_TRANSPARENT tag to YES to generate images with a transparent
+# background. This is disabled by default, because dot on Windows does not
+# seem to support this out of the box. Warning: Depending on the platform used,
+# enabling this option may lead to badly anti-aliased labels on the edges of
+# a graph (i.e. they become hard to read).
+
+DOT_TRANSPARENT = NO
+
+# Set the DOT_MULTI_TARGETS tag to YES allow dot to generate multiple output
+# files in one run (i.e. multiple -o and -T options on the command line). This
+# makes dot run faster, but since only newer versions of dot (>1.8.10)
+# support this, this feature is disabled by default.
+
+DOT_MULTI_TARGETS = NO
+
+# If the GENERATE_LEGEND tag is set to YES (the default) Doxygen will
+# generate a legend page explaining the meaning of the various boxes and
+# arrows in the dot generated graphs.
+
+GENERATE_LEGEND = YES
+
+# If the DOT_CLEANUP tag is set to YES (the default) Doxygen will
+# remove the intermediate dot files that are used to generate
+# the various graphs.
+
+DOT_CLEANUP = YES
+
+#---------------------------------------------------------------------------
+# Options related to the search engine
+#---------------------------------------------------------------------------
+
+# The SEARCHENGINE tag specifies whether or not a search engine should be
+# used. If set to NO the values of all tags below this one will be ignored.
+
+SEARCHENGINE = NO
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/ext_doc/main_ext.f b/HySoP/src/Unstable/LEGI/doc/doxygen/ext_doc/main_ext.f
new file mode 100644
index 0000000000000000000000000000000000000000..84c0e75d1ee5f93f545be45021cb5ad08e4e6966
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/ext_doc/main_ext.f
@@ -0,0 +1,140 @@
+!> \mainpage CodeScalar Documentation
+!!
+!! \section intro_sec Introduction
+!!
+!! This is Code_scalar documentation !
+!!
+!! \section install_sec Installation
+!!
+!! \subsection tools_subsec Tools required:
+!! - cmake
+!! - fftw
+!! - mpi
+!!
+!! \subsection compile Compilation
+!! - Obtain the code from the svn repositories.
+!! - Go the the code location (the folder must contains at least "src" and "CMake" folders and a "CMakeList" file)
+!! - Create a build folder : \verbatim $ mkdir build \endverbatim
+!! - Run cmake : \verbatim $ cmake .. \endverbatim
+!! - Compile : \verbatim $ make \endverbatim
+!!
+!! \subsection add_comp Advanced compilation options
+!! This section explain how to perform advanced task. All these task can
+!! only be performed after having running at least one time cmake.
+!!
+!! - Update the fortran file generated with the .fortran file : <tt>$ make fortran_file</tt>
+!! - Generate (or update) doxygen documentation : <tt> $ make doc</tt>
+!! - Obtain the list of possible target for a make : <tt>$ make help</tt>
+!! - A <tt>$ make VERBOSE=1</tt> shows all the command running by the make command.
+!!
+!! The CMakeLists contains some flag wich can be changed
+!! - <tt> WITH_TESTS</tt>: to compile tests.
+!! - <tt>WITH_EXAMPLE</tt>: to compile benchmark
+!! - <tt>GENERATE_SRC</tt>: to (re-) generate source file from *.fortran file
+!!
+!! \section running Running the program
+!! Run ScaleExe
+!!
+!! \section doc Additionnal documentation
+!!This manual is divided in the following sections:
+!!- \subpage part_doc : some information about particle method implementation
+!!- \subpage output_doc : some information about posprocessing and input/output
+!!
+
+!-----------------------------------------------------------
+!
+!> \page part_doc About particle method implementation
+!! This page described the implementation of the advection solver based
+!! on particle method.
+!!
+!! \section part_intro Introduction
+!!
+!! \subsection notation Some notation
+!! All the file using some common notation
+!! - local domain of each processus are indiced from 1 to N_proc.
+!! - d_sc = (scalar) space step
+!! - ind = mesh (or particles) indice. As we use fortran, it goes
+!! from 1 to N_proc
+!! - pos = particles position. In accordance to ind, if there is one
+!! particle at each mesh point, it goes from d_sci to (N_proc)*d_sc.
+!! A particle "i" belong to the local subdomain if and only if pos(i)
+!! belongs to [d_sc;d_sc*(N_proc+1)[.
+!! - pos_adim = adimensionned particles position. In accordance to ind, if there is one
+!! particle at each mesh point, it goes from 1 to N_proc
+!!
+!! \subsection Todo
+!! \todo
+!! - travailler par bloc de lignes plutôt que par ligne 1D
+!! - petits groupes => moins d'usage mémoire en local, plus de
+!! messages qui sont chacun plus petits.
+!! - grands groupes => mutualisation des communications (moins
+!! nombreux mais message plus grands) et nécessite plus de mémoire
+!! en local. (à éviter si la ram est légère.)
+!! - add new remeshing schemes:
+!! - corrected lambda 4
+!! - M'6
+!! - Au sein d'un group de ligne, on peut utiliser un autre niveau de
+!! parallélisme type open_mp.
+!
+!-----------------------------------------------------------
+
+
+!-----------------------------------------------------------
+!
+!> \page output_doc About input and output
+!! This page described the implementation of the IO
+!!
+!! \section io_intro Introduction
+!! Two output format are implemented : avs files and parallel vtk xml
+!! files.
+!! The first one is provided by the "avs" module (see avs.F90) and the
+!! second one by "parallel_io" module. The both can be used for output
+!! during a simulation on a parrallel computer.
+!!
+!! \section Main differences between the two output format
+!! - avs file can also be used as input files (input at format "vtk xml"
+!! will be implement later)
+!! - number of files created and parallel context:
+!! - the "vtk xml" standart allows to write output in more than one
+!! files. The module provided in scale will perform write in a file
+!! per processus. More precisly, output will not need any communication
+!! neither mpi_io. But it also means it will create a lot of file
+!! if the number of processes is high.
+!! - on the contrary, the avs module produces only one ouput file
+!! containing all the data.
+!! - Note that in "small" cluster, the write on hard disk are
+!! sequential. In future update, the number of output for "vtk
+!! xml" file will be defined by the user.
+!! - both output are done at binary format.
+!!
+!! \subsection Todo
+!! \todo
+!! - implement hdf5 output:
+!! - in first time, by creating one output file by mpi processus
+!! - then allow the user to gather some processus in one output file in
+!! oder to limit the number of output and initialize this to a reasonnable
+!! default value.
+!! - implement hdf5 input in order to restart computation to a given state.
+!! - define the specification: what is conserved from the previous
+!! computations ?
+!! - obviously input parameters, last field values, current time ...
+!! - ... but it is also possible to re-initialize memomry to its last
+!! state
+!! - implement the corresponding output (more than the standart ouput)
+!! and the corresponding input.
+!! - to deal with unexpected bug, add minimal information to standart
+!! output and implement matching input routines in order to also be able
+!! to restart a bugged simulation.
+!! - implement xml input
+!
+!-----------------------------------------------------------
+
+!> @defgroup part Particular method
+!! Details about particle method for scalar advection
+
+!> @defgroup output Input/Ouput procedures
+!! This group gather all the IO tools, including AVS IO and vtk xml output.
+
+!> @defgroup cart_structure Cartesian mpi topology and mesh
+!! This group gather module devoted to mpi topology and some of the
+!! associated mesh informations.
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.eps b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.eps
new file mode 100644
index 0000000000000000000000000000000000000000..9a178fc06696c999ec5a594f0827fe06ccf22266
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.eps
@@ -0,0 +1,264 @@
+%!PS-Adobe-2.0 EPSF-2.0
+%%Title: datalayout.fig
+%%Creator: fig2dev Version 3.2 Patchlevel 5
+%%CreationDate: Tue Jul 19 12:09:38 2011
+%%For: begou@thor (Patrick Begou)
+%%BoundingBox: 0 0 580 470
+%Magnification: 1.0000
+%%EndComments
+%%BeginProlog
+/$F2psDict 200 dict def
+$F2psDict begin
+$F2psDict /mtrx matrix put
+/col-1 {0 setgray} bind def
+/col0 {0.000 0.000 0.000 srgb} bind def
+/col1 {0.000 0.000 1.000 srgb} bind def
+/col2 {0.000 1.000 0.000 srgb} bind def
+/col3 {0.000 1.000 1.000 srgb} bind def
+/col4 {1.000 0.000 0.000 srgb} bind def
+/col5 {1.000 0.000 1.000 srgb} bind def
+/col6 {1.000 1.000 0.000 srgb} bind def
+/col7 {1.000 1.000 1.000 srgb} bind def
+/col8 {0.000 0.000 0.560 srgb} bind def
+/col9 {0.000 0.000 0.690 srgb} bind def
+/col10 {0.000 0.000 0.820 srgb} bind def
+/col11 {0.530 0.810 1.000 srgb} bind def
+/col12 {0.000 0.560 0.000 srgb} bind def
+/col13 {0.000 0.690 0.000 srgb} bind def
+/col14 {0.000 0.820 0.000 srgb} bind def
+/col15 {0.000 0.560 0.560 srgb} bind def
+/col16 {0.000 0.690 0.690 srgb} bind def
+/col17 {0.000 0.820 0.820 srgb} bind def
+/col18 {0.560 0.000 0.000 srgb} bind def
+/col19 {0.690 0.000 0.000 srgb} bind def
+/col20 {0.820 0.000 0.000 srgb} bind def
+/col21 {0.560 0.000 0.560 srgb} bind def
+/col22 {0.690 0.000 0.690 srgb} bind def
+/col23 {0.820 0.000 0.820 srgb} bind def
+/col24 {0.500 0.190 0.000 srgb} bind def
+/col25 {0.630 0.250 0.000 srgb} bind def
+/col26 {0.750 0.380 0.000 srgb} bind def
+/col27 {1.000 0.500 0.500 srgb} bind def
+/col28 {1.000 0.630 0.630 srgb} bind def
+/col29 {1.000 0.750 0.750 srgb} bind def
+/col30 {1.000 0.880 0.880 srgb} bind def
+/col31 {1.000 0.840 0.000 srgb} bind def
+
+end
+save
+newpath 0 470 moveto 0 0 lineto 580 0 lineto 580 470 lineto closepath clip newpath
+-27.6 496.8 translate
+1 -1 scale
+
+/cp {closepath} bind def
+/ef {eofill} bind def
+/gr {grestore} bind def
+/gs {gsave} bind def
+/sa {save} bind def
+/rs {restore} bind def
+/l {lineto} bind def
+/m {moveto} bind def
+/rm {rmoveto} bind def
+/n {newpath} bind def
+/s {stroke} bind def
+/sh {show} bind def
+/slc {setlinecap} bind def
+/slj {setlinejoin} bind def
+/slw {setlinewidth} bind def
+/srgb {setrgbcolor} bind def
+/rot {rotate} bind def
+/sc {scale} bind def
+/sd {setdash} bind def
+/ff {findfont} bind def
+/sf {setfont} bind def
+/scf {scalefont} bind def
+/sw {stringwidth} bind def
+/tr {translate} bind def
+/tnt {dup dup currentrgbcolor
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb}
+ bind def
+/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul
+ 4 -2 roll mul srgb} bind def
+/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def
+/$F2psEnd {$F2psEnteredState restore end} def
+
+$F2psBegin
+10 setmiterlimit
+0 slj 0 slc
+ 0.06299 0.06299 sc
+%%EndProlog
+%
+% Fig objects follow
+%
+%
+% here starts figure with depth 50
+% Polyline
+0 slj
+0 slc
+7.500 slw
+n 4605 2070 m 4500 2070 4500 3315 105 arcto 4 {pop} repeat
+ 4500 3420 7320 3420 105 arcto 4 {pop} repeat
+ 7425 3420 7425 2175 105 arcto 4 {pop} repeat
+ 7425 2070 4605 2070 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+/Times-Bold ff 222.25 scf sf
+6030 2430 m
+gs 1 -1 sc (module maindatalayout) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+5895 2925 m
+gs 1 -1 sc (Global parameters) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+5895 3195 m
+gs 1 -1 sc (Global function) dup sw pop 2 div neg 0 rm col0 sh gr
+% Polyline
+n 450 3150 m 3645 3150 l 3645 4500 l 450 4500 l
+ cp gs col0 s gr
+/Times-BoldItalic ff 222.25 scf sf
+2025 3420 m
+gs 1 -1 sc (implementdatalayout.Fortran) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Italic ff 190.50 scf sf
+1935 3870 m
+gs 1 -1 sc (Module generic implementation) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Italic ff 190.50 scf sf
+1890 4185 m
+gs 1 -1 sc (with tags.) dup sw pop 2 div neg 0 rm col0 sh gr
+% Polyline
+n 4830 450 m 4725 450 4725 1290 105 arcto 4 {pop} repeat
+ 4725 1395 7140 1395 105 arcto 4 {pop} repeat
+ 7245 1395 7245 555 105 arcto 4 {pop} repeat
+ 7245 450 4830 450 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+/Times-Bold ff 222.25 scf sf
+5940 720 m
+gs 1 -1 sc (module mpilayout) dup sw pop 2 div neg 0 rm col0 sh gr
+% Polyline
+n 6810 4950 m 6705 4950 6705 6150 105 arcto 4 {pop} repeat
+ 6705 6255 9525 6255 105 arcto 4 {pop} repeat
+ 9630 6255 9630 5055 105 arcto 4 {pop} repeat
+ 9630 4950 6810 4950 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+/Times-Bold ff 222.25 scf sf
+8145 5220 m
+gs 1 -1 sc (module cmplxdatalayout) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8145 5625 m
+gs 1 -1 sc (Datalayout code and functions) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8055 5850 m
+gs 1 -1 sc (for complex type values.) dup sw pop 2 div neg 0 rm col0 sh gr
+% Polyline
+n 4920 6975 m 4815 6975 4815 7770 105 arcto 4 {pop} repeat
+ 4815 7875 7815 7875 105 arcto 4 {pop} repeat
+ 7920 7875 7920 7080 105 arcto 4 {pop} repeat
+ 7920 6975 4920 6975 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+/Times-Bold ff 222.25 scf sf
+6435 7290 m
+gs 1 -1 sc (module datalayout) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6435 7695 m
+gs 1 -1 sc (Generic interface for datalayout) dup sw pop 2 div neg 0 rm col0 sh gr
+% Polyline
+30.000 slw
+gs clippath
+5962 1674 m 5962 1380 l 5827 1380 l 5827 1674 l 5827 1674 l 5895 1449 l 5962 1674 l cp
+eoclip
+n 5895 2070 m
+ 5895 1395 l gs col0 s gr gr
+
+% arrowhead
+n 5962 1674 m 5895 1449 l 5827 1674 l 5895 1629 l 5962 1674 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+gs clippath
+6340 3531 m 6103 3356 l 6022 3465 l 6259 3640 l 6259 3640 l 6119 3452 l 6340 3531 l cp
+eoclip
+n 8145 4950 m
+ 6075 3420 l gs col0 s gr gr
+
+% arrowhead
+n 6340 3531 m 6119 3452 l 6259 3640 l 6263 3558 l 6340 3531 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+gs clippath
+5695 3685 m 5868 3447 l 5759 3368 l 5586 3606 l 5586 3606 l 5773 3464 l 5695 3685 l cp
+eoclip
+n 4725 4905 m
+ 5805 3420 l gs col0 s gr gr
+
+% arrowhead
+n 5695 3685 m 5773 3464 l 5586 3606 l 5667 3609 l 5695 3685 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+gs clippath
+5143 6351 m 4873 6232 l 4819 6355 l 5088 6474 l 5088 6474 l 4910 6322 l 5143 6351 l cp
+eoclip
+n 6390 6975 m
+ 4860 6300 l gs col0 s gr gr
+
+% arrowhead
+n 5143 6351 m 4910 6322 l 5088 6474 l 5074 6394 l 5143 6351 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+gs clippath
+7868 6425 m 8140 6311 l 8087 6186 l 7816 6301 l 7816 6301 l 8050 6276 l 7868 6425 l cp
+eoclip
+n 6390 6975 m
+ 8100 6255 l gs col0 s gr gr
+
+% arrowhead
+n 7868 6425 m 8050 6276 l 7816 6301 l 7884 6345 l 7868 6425 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+ [120] 0 sd
+gs clippath
+4221 4764 m 4364 4957 l 4473 4876 l 4330 4684 l 4330 4684 l 4383 4869 l 4221 4764 l cp
+eoclip
+n 3645 3870 m
+ 4410 4905 l gs col0 s gr gr
+ [] 0 sd
+% arrowhead
+n 4221 4764 m 4383 4869 l 4330 4684 l 4221 4764 l cp gs col7 1.00 shd ef gr col0 s
+% Polyline
+ [120] 0 sd
+gs clippath
+7460 4957 m 7692 5019 l 7726 4888 l 7495 4827 l 7495 4827 l 7652 4939 l 7460 4957 l cp
+eoclip
+n 3645 3870 m
+ 7695 4950 l gs col0 s gr gr
+ [] 0 sd
+% arrowhead
+n 7460 4957 m 7652 4939 l 7495 4827 l 7460 4957 l cp gs col7 1.00 shd ef gr col0 s
+% Polyline
+7.500 slw
+n 3480 4905 m 3375 4905 3375 6195 105 arcto 4 {pop} repeat
+ 3375 6300 6195 6300 105 arcto 4 {pop} repeat
+ 6300 6300 6300 5010 105 arcto 4 {pop} repeat
+ 6300 4905 3480 4905 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+/Times-Roman ff 190.50 scf sf
+6390 4500 m
+gs 1 -1 sc 344.0 rot (automatic code generation) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4860 4635 m
+gs 1 -1 sc 52.0 rot (use) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7240 4182 m
+gs 1 -1 sc 328.0 rot (use) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4725 5580 m
+gs 1 -1 sc (Datalayout code and functions) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4680 5850 m
+gs 1 -1 sc (for real type values.) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Bold ff 222.25 scf sf
+4815 5175 m
+gs 1 -1 sc (module realdatalayout) dup sw pop 2 div neg 0 rm col0 sh gr
+% here ends figure;
+$F2psEnd
+rs
+showpage
+%%Trailer
+%EOF
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.fig b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.fig
new file mode 100644
index 0000000000000000000000000000000000000000..474af97ddc56a63235fa3e567cb923ac32061870
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.fig
@@ -0,0 +1,70 @@
+#FIG 3.2 Produced by xfig version 3.2.5
+Landscape
+Center
+Metric
+A4
+100.00
+Single
+-2
+1200 2
+6 4500 2070 7425 3420
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 7425 3420 7425 2070 4500 2070 4500 3420 7425 3420
+4 1 0 50 -1 2 14 0.0000 4 210 2400 6030 2430 module maindatalayout\001
+4 1 0 50 -1 0 12 0.0000 4 180 1470 5895 2925 Global parameters\001
+4 1 0 50 -1 0 12 0.0000 4 135 1290 5895 3195 Global function\001
+-6
+6 450 3150 3645 4500
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 450 3150 3645 3150 3645 4500 450 4500 450 3150
+4 1 0 50 -1 3 14 0.0000 4 210 2865 2025 3420 implementdatalayout.Fortran\001
+4 1 0 50 -1 1 12 0.0000 4 180 2610 1935 3870 Module generic implementation\001
+4 1 0 50 -1 1 12 0.0000 4 180 795 1890 4185 with tags.\001
+-6
+6 4725 450 7245 1395
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 7245 1395 7245 450 4725 450 4725 1395 7245 1395
+4 1 0 50 -1 2 14 0.0000 4 210 1830 5940 720 module mpilayout\001
+-6
+6 6705 4950 9630 6255
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 9630 6255 9630 4950 6705 4950 6705 6255 9630 6255
+4 1 0 50 -1 2 14 0.0000 4 210 2505 8145 5220 module cmplxdatalayout\001
+4 1 0 50 -1 0 12 0.0000 4 180 2490 8145 5625 Datalayout code and functions\001
+4 1 0 50 -1 0 12 0.0000 4 180 1995 8055 5850 for complex type values.\001
+-6
+6 4815 6975 7920 7875
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 7920 7875 7920 6975 4815 6975 4815 7875 7920 7875
+4 1 0 50 -1 2 14 0.0000 4 210 1890 6435 7290 module datalayout\001
+4 1 0 50 -1 0 12 0.0000 4 180 2565 6435 7695 Generic interface for datalayout\001
+-6
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 5895 2070 5895 1395
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 8145 4950 6075 3420
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 4725 4905 5805 3420
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 6390 6975 4860 6300
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 6390 6975 8100 6255
+2 1 1 3 0 7 50 -1 -1 8.000 0 0 -1 1 0 2
+ 1 0 3.00 135.00 180.00
+ 3645 3870 4410 4905
+2 1 1 3 0 7 50 -1 -1 8.000 0 0 -1 1 0 2
+ 1 0 3.00 135.00 180.00
+ 3645 3870 7695 4950
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 6300 6300 6300 4905 3375 4905 3375 6300 6300 6300
+4 1 0 50 -1 0 12 6.0039 4 180 2160 6390 4500 automatic code generation\001
+4 1 0 50 -1 0 12 0.9076 4 90 270 4860 4635 use\001
+4 1 0 50 -1 0 12 5.7247 4 90 270 7240 4182 use\001
+4 1 0 50 -1 0 12 0.0000 4 180 2490 4725 5580 Datalayout code and functions\001
+4 1 0 50 -1 0 12 0.0000 4 180 1590 4680 5850 for real type values.\001
+4 1 0 50 -1 2 14 0.0000 4 210 2280 4815 5175 module realdatalayout\001
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.png b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.png
new file mode 100644
index 0000000000000000000000000000000000000000..185db320b4302bf7add1f420f86560eea5cb059b
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/doxygen/images/datalayout.png differ
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.eps b/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.eps
new file mode 100644
index 0000000000000000000000000000000000000000..87459da4971c774ea290e27dcca53b7b615b34d5
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.eps
@@ -0,0 +1,3766 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: (atend)
+%%LanguageLevel: 2
+%%Creator: Grace-5.1.21
+%%CreationDate: Thu Jan 26 09:34:17 2012
+%%DocumentData: Clean8Bit
+%%Orientation: Portrait
+%%Title: Untitled
+%%For: begou
+%%DocumentNeededResources: (atend)
+%%EndComments
+%%BeginProlog
+/m {moveto} def
+/l {lineto} def
+/s {stroke} def
+/n {newpath} def
+/c {closepath} def
+/RL {rlineto} def
+/SLW {setlinewidth} def
+/GS {gsave} def
+/GR {grestore} def
+/SC {setcolor} def
+/SGRY {setgray} def
+/SRGB {setrgbcolor} def
+/SD {setdash} def
+/SLC {setlinecap} def
+/SLJ {setlinejoin} def
+/SCS {setcolorspace} def
+/FFSF {findfont setfont} def
+/CC {concat} def
+/PXL {n m 0 0 RL s} def
+/Color0 {1.0000 1.0000 1.0000} def
+/Color1 {0.0000 0.0000 0.0000} def
+/Color2 {1.0000 0.0000 0.0000} def
+/Color3 {0.0000 1.0000 0.0000} def
+/Color4 {0.0000 0.0000 1.0000} def
+/Color5 {1.0000 1.0000 0.0000} def
+/Color6 {0.7373 0.5608 0.5608} def
+/Color7 {0.8627 0.8627 0.8627} def
+/Color8 {0.5804 0.0000 0.8275} def
+/Color9 {0.0000 1.0000 1.0000} def
+/Color10 {1.0000 0.0000 1.0000} def
+/Color11 {1.0000 0.6471 0.0000} def
+/Color12 {0.4471 0.1294 0.7373} def
+/Color13 {0.4039 0.0275 0.2824} def
+/Color14 {0.2510 0.8784 0.8157} def
+/Color15 {0.0000 0.5451 0.0000} def
+/Color16 {0.7529 0.7529 0.7529} def
+/Color17 {0.5059 0.5059 0.5059} def
+/Color18 {0.2588 0.2588 0.2588} def
+/PTRN {
+ /pat_bits exch def
+ <<
+ /PaintType 2
+ /PatternType 1 /TilingType 1
+ /BBox[0 0 16 16]
+ /XStep 16 /YStep 16
+ /PaintProc {
+ pop
+ 16 16 true [-1 0 0 -1 16 16] pat_bits imagemask
+ }
+ >>
+ [0.0017 0 0 0.0017 0 0]
+ makepattern
+} def
+/Pattern0 {<0000000000000000000000000000000000000000000000000000000000000000> PTRN} bind def
+/Pattern1 {<ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff> PTRN} bind def
+/Pattern2 {<eeeeffffbbbbffffeeeeffffbbbbffffeeeeffffbbbbffffeeeeffffbbbbffff> PTRN} bind def
+/Pattern3 {<eeeebbbbeeeebbbbeeeebbbbeeeebbbbeeeebbbbeeeebbbbeeeebbbbeeeebbbb> PTRN} bind def
+/Pattern4 {<5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa5555aaaa> PTRN} bind def
+/Pattern5 {<1111444411114444111144441111444411114444111144441111444411114444> PTRN} bind def
+/Pattern6 {<1111000044440000111100004444000011110000444400001111000044440000> PTRN} bind def
+/Pattern7 {<1010000000000000010100000000000010100000000000000101000000000000> PTRN} bind def
+/Pattern8 {<0000000000000000000000000000000000000000000000000000000000000000> PTRN} bind def
+/Pattern9 {<1e1e0f0f8787c3c3e1e1f0f078783c3c1e1e0f0f8787c3c3e1e1f0f078783c3c> PTRN} bind def
+/Pattern10 {<7878f0f0e1e1c3c387870f0f1e1e3c3c7878f0f0e1e1c3c387870f0f1e1e3c3c> PTRN} bind def
+/Pattern11 {<3333333333333333333333333333333333333333333333333333333333333333> PTRN} bind def
+/Pattern12 {<ffffffff00000000ffffffff00000000ffffffff00000000ffffffff00000000> PTRN} bind def
+/Pattern13 {<8181424224241818181824244242818181814242242418181818242442428181> PTRN} bind def
+/Pattern14 {<8080404020201010080804040202010180804040202010100808040402020101> PTRN} bind def
+/Pattern15 {<0101020204040808101020204040808001010202040408081010202040408080> PTRN} bind def
+/Pattern16 {<2222222222222222222222222222222222222222222222222222222222222222> PTRN} bind def
+/Pattern17 {<0000ffff000000000000ffff000000000000ffff000000000000ffff00000000> PTRN} bind def
+/Pattern18 {<2222ffff222222222222ffff222222222222ffff222222222222ffff22222222> PTRN} bind def
+/Pattern19 {<ffffffff33333333ffffffff33333333ffffffff33333333ffffffff33333333> PTRN} bind def
+/Pattern20 {<0f0f0f0f0f0f0f0ff0f0f0f0f0f0f0f00f0f0f0f0f0f0f0ff0f0f0f0f0f0f0f0> PTRN} bind def
+/Pattern21 {<ff00ff00ff00ff00ff00ff00ff00ff0000ff00ff00ff00ff00ff00ff00ff00ff> PTRN} bind def
+/Pattern22 {<8001800180018001800180018001ffffffff8001800180018001800180018001> PTRN} bind def
+/Pattern23 {<c003c003c003c003c003c003ffffffffffffffffc003c003c003c003c003c003> PTRN} bind def
+/Pattern24 {<040404040404ffff404040404040ffff040404040404ffff404040404040ffff> PTRN} bind def
+/Pattern25 {<180018001800180018001800ffffffff001800180018001800180018ffffffff> PTRN} bind def
+/Pattern26 {<1111b8b87c7c3a3a1111a3a3c7c78b8b1111b8b87c7c3a3a1111a3a3c7c78b8b> PTRN} bind def
+/Pattern27 {<101010102828c7c70101010182827c7c101010102828c7c70101010182827c7c> PTRN} bind def
+/Pattern28 {<1c1c121211112121c1c12121111112121c1c121211112121c1c1212111111212> PTRN} bind def
+/Pattern29 {<3e3e414180808080e3e31414080808083e3e414180808080e3e3141408080808> PTRN} bind def
+/Pattern30 {<4848888884848383848488884848383848488888848483838484888848483838> PTRN} bind def
+/Pattern31 {<03030404080808080c0c12122121c0c003030404080808080c0c12122121c0c0> PTRN} bind def
+/ellipsedict 8 dict def
+ellipsedict /mtrx matrix put
+/EARC {
+ ellipsedict begin
+ /endangle exch def
+ /startangle exch def
+ /yrad exch def
+ /xrad exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ xrad yrad scale
+ 0 0 1 startangle endangle arc
+ savematrix setmatrix
+ end
+} def
+/TL {
+ /kcomp exch def
+ /linewidth exch def
+ /offset exch def
+ GS
+ 0 offset rmoveto
+ linewidth SLW
+ dup stringwidth exch kcomp add exch RL s
+ GR
+} def
+/KINIT
+{
+ /kvector exch def
+ /kid 0 def
+} def
+/KPROC
+{
+ pop pop
+ kvector kid get
+ 0 rmoveto
+ /kid 1 kid add def
+} def
+/DefEncoding [
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /space
+ /exclam
+ /quotedbl
+ /numbersign
+ /dollar
+ /percent
+ /ampersand
+ /quoteright
+ /parenleft
+ /parenright
+ /asterisk
+ /plus
+ /comma
+ /hyphen
+ /period
+ /slash
+ /zero
+ /one
+ /two
+ /three
+ /four
+ /five
+ /six
+ /seven
+ /eight
+ /nine
+ /colon
+ /semicolon
+ /less
+ /equal
+ /greater
+ /question
+ /at
+ /A
+ /B
+ /C
+ /D
+ /E
+ /F
+ /G
+ /H
+ /I
+ /J
+ /K
+ /L
+ /M
+ /N
+ /O
+ /P
+ /Q
+ /R
+ /S
+ /T
+ /U
+ /V
+ /W
+ /X
+ /Y
+ /Z
+ /bracketleft
+ /backslash
+ /bracketright
+ /asciicircum
+ /underscore
+ /grave
+ /a
+ /b
+ /c
+ /d
+ /e
+ /f
+ /g
+ /h
+ /i
+ /j
+ /k
+ /l
+ /m
+ /n
+ /o
+ /p
+ /q
+ /r
+ /s
+ /t
+ /u
+ /v
+ /w
+ /x
+ /y
+ /z
+ /braceleft
+ /bar
+ /braceright
+ /asciitilde
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /.notdef
+ /space
+ /exclamdown
+ /cent
+ /sterling
+ /currency
+ /yen
+ /brokenbar
+ /section
+ /dieresis
+ /copyright
+ /ordfeminine
+ /guillemotleft
+ /logicalnot
+ /hyphen
+ /registered
+ /macron
+ /degree
+ /plusminus
+ /twosuperior
+ /threesuperior
+ /acute
+ /mu
+ /paragraph
+ /periodcentered
+ /cedilla
+ /onesuperior
+ /ordmasculine
+ /guillemotright
+ /onequarter
+ /onehalf
+ /threequarters
+ /questiondown
+ /Agrave
+ /Aacute
+ /Acircumflex
+ /Atilde
+ /Adieresis
+ /Aring
+ /AE
+ /Ccedilla
+ /Egrave
+ /Eacute
+ /Ecircumflex
+ /Edieresis
+ /Igrave
+ /Iacute
+ /Icircumflex
+ /Idieresis
+ /Eth
+ /Ntilde
+ /Ograve
+ /Oacute
+ /Ocircumflex
+ /Otilde
+ /Odieresis
+ /multiply
+ /Oslash
+ /Ugrave
+ /Uacute
+ /Ucircumflex
+ /Udieresis
+ /Yacute
+ /Thorn
+ /germandbls
+ /agrave
+ /aacute
+ /acircumflex
+ /atilde
+ /adieresis
+ /aring
+ /ae
+ /ccedilla
+ /egrave
+ /eacute
+ /ecircumflex
+ /edieresis
+ /igrave
+ /iacute
+ /icircumflex
+ /idieresis
+ /eth
+ /ntilde
+ /ograve
+ /oacute
+ /ocircumflex
+ /otilde
+ /odieresis
+ /divide
+ /oslash
+ /ugrave
+ /uacute
+ /ucircumflex
+ /udieresis
+ /yacute
+ /thorn
+ /ydieresis
+] def
+%%EndProlog
+%%BeginSetup
+%%EndSetup
+594.96 594.96 scale
+n
+0.0000 0.0000 m
+0.0000 1.0000 l
+1.4151 1.0000 l
+1.4151 0.0000 l
+c
+[/DeviceRGB] SCS
+Color0 SC
+fill
+[/DeviceRGB] SCS
+Color2 SC
+[] 0 SD
+0.0015 SLW
+0 SLC
+0 SLJ
+n
+0.1500 0.8127 m
+0.1507 0.8121 l
+0.1513 0.8115 l
+0.1520 0.8108 l
+0.1527 0.8100 l
+0.1533 0.8093 l
+0.1540 0.8086 l
+0.1547 0.8079 l
+0.1553 0.8071 l
+0.1560 0.8063 l
+0.1567 0.8056 l
+0.1573 0.8049 l
+0.1580 0.8041 l
+0.1587 0.8033 l
+0.1593 0.8024 l
+0.1600 0.8017 l
+0.1607 0.8009 l
+0.1613 0.8001 l
+0.1620 0.7992 l
+0.1627 0.7983 l
+0.1633 0.7975 l
+0.1640 0.7967 l
+0.1647 0.7959 l
+0.1653 0.7950 l
+0.1660 0.7940 l
+0.1667 0.7932 l
+0.1673 0.7924 l
+0.1680 0.7915 l
+0.1687 0.7906 l
+0.1693 0.7896 l
+0.1700 0.7887 l
+0.1707 0.7879 l
+0.1713 0.7870 l
+0.1720 0.7861 l
+0.1727 0.7852 l
+0.1733 0.7842 l
+0.1740 0.7832 l
+0.1747 0.7824 l
+0.1753 0.7815 l
+0.1760 0.7806 l
+0.1767 0.7797 l
+0.1773 0.7787 l
+0.1780 0.7777 l
+0.1787 0.7767 l
+0.1793 0.7758 l
+0.1800 0.7749 l
+0.1807 0.7739 l
+0.1813 0.7730 l
+0.1820 0.7719 l
+0.1827 0.7709 l
+0.1833 0.7699 l
+0.1840 0.7689 l
+0.1847 0.7680 l
+0.1853 0.7670 l
+0.1860 0.7661 l
+0.1867 0.7651 l
+0.1873 0.7642 l
+0.1880 0.7632 l
+0.1887 0.7621 l
+0.1893 0.7611 l
+0.1900 0.7600 l
+0.1907 0.7590 l
+0.1913 0.7580 l
+0.1920 0.7570 l
+0.1927 0.7560 l
+0.1933 0.7549 l
+0.1940 0.7539 l
+0.1947 0.7528 l
+0.1953 0.7517 l
+0.1960 0.7505 l
+0.1967 0.7494 l
+0.1973 0.7489 l
+0.1980 0.7484 l
+0.1987 0.7479 l
+0.1993 0.7476 l
+0.2000 0.7472 l
+0.2007 0.7468 l
+0.2013 0.7464 l
+0.2020 0.7460 l
+0.2027 0.7456 l
+0.2033 0.7452 l
+0.2040 0.7449 l
+0.2047 0.7445 l
+0.2053 0.7441 l
+0.2060 0.7437 l
+0.2067 0.7434 l
+0.2073 0.7430 l
+0.2080 0.7426 l
+0.2087 0.7422 l
+0.2093 0.7419 l
+0.2100 0.7415 l
+0.2107 0.7411 l
+0.2113 0.7408 l
+0.2120 0.7404 l
+0.2127 0.7401 l
+0.2133 0.7398 l
+0.2140 0.7395 l
+0.2147 0.7393 l
+0.2153 0.7391 l
+0.2160 0.7388 l
+0.2167 0.7386 l
+0.2173 0.7384 l
+0.2180 0.7381 l
+0.2187 0.7379 l
+0.2193 0.7377 l
+0.2200 0.7375 l
+0.2207 0.7373 l
+0.2213 0.7371 l
+0.2220 0.7369 l
+0.2227 0.7366 l
+0.2233 0.7364 l
+0.2240 0.7362 l
+0.2247 0.7360 l
+0.2253 0.7358 l
+0.2260 0.7356 l
+0.2267 0.7353 l
+0.2273 0.7351 l
+0.2280 0.7349 l
+0.2287 0.7346 l
+0.2293 0.7344 l
+0.2300 0.7342 l
+0.2307 0.7339 l
+0.2313 0.7337 l
+0.2320 0.7334 l
+0.2327 0.7331 l
+0.2333 0.7329 l
+0.2340 0.7326 l
+0.2347 0.7324 l
+0.2353 0.7321 l
+0.2360 0.7318 l
+0.2367 0.7316 l
+0.2373 0.7313 l
+0.2380 0.7310 l
+0.2387 0.7307 l
+0.2393 0.7303 l
+0.2400 0.7300 l
+0.2407 0.7297 l
+0.2413 0.7294 l
+0.2420 0.7291 l
+0.2427 0.7287 l
+0.2433 0.7284 l
+0.2440 0.7281 l
+0.2447 0.7277 l
+0.2453 0.7273 l
+0.2460 0.7269 l
+0.2467 0.7266 l
+0.2473 0.7262 l
+0.2480 0.7258 l
+0.2487 0.7253 l
+0.2493 0.7249 l
+0.2500 0.7245 l
+0.2507 0.7241 l
+0.2513 0.7237 l
+0.2520 0.7233 l
+0.2527 0.7229 l
+0.2533 0.7224 l
+0.2540 0.7220 l
+0.2547 0.7215 l
+0.2553 0.7211 l
+0.2560 0.7206 l
+0.2567 0.7201 l
+0.2573 0.7196 l
+0.2580 0.7191 l
+0.2587 0.7186 l
+0.2593 0.7181 l
+0.2600 0.7175 l
+0.2607 0.7170 l
+0.2613 0.7164 l
+0.2620 0.7158 l
+0.2627 0.7152 l
+0.2633 0.7146 l
+0.2640 0.7140 l
+0.2647 0.7135 l
+0.2653 0.7129 l
+0.2660 0.7123 l
+0.2667 0.7117 l
+0.2673 0.7111 l
+0.2680 0.7105 l
+0.2687 0.7098 l
+0.2693 0.7092 l
+0.2700 0.7085 l
+0.2707 0.7079 l
+0.2713 0.7072 l
+0.2720 0.7065 l
+0.2727 0.7058 l
+0.2733 0.7051 l
+0.2740 0.7044 l
+0.2747 0.7036 l
+0.2753 0.7029 l
+0.2760 0.7021 l
+0.2767 0.7014 l
+0.2773 0.7007 l
+0.2780 0.6999 l
+0.2787 0.6991 l
+0.2793 0.6984 l
+0.2800 0.6976 l
+0.2807 0.6967 l
+0.2813 0.6959 l
+0.2820 0.6951 l
+0.2827 0.6943 l
+0.2833 0.6934 l
+0.2840 0.6926 l
+0.2847 0.6917 l
+0.2853 0.6908 l
+0.2860 0.6900 l
+0.2867 0.6891 l
+0.2873 0.6882 l
+0.2880 0.6873 l
+0.2887 0.6864 l
+0.2893 0.6855 l
+0.2900 0.6846 l
+0.2907 0.6837 l
+0.2913 0.6828 l
+0.2920 0.6818 l
+0.2927 0.6809 l
+0.2933 0.6799 l
+0.2940 0.6790 l
+0.2947 0.6780 l
+0.2953 0.6770 l
+0.2960 0.6760 l
+0.2967 0.6751 l
+0.2973 0.6741 l
+0.2980 0.6732 l
+0.2987 0.6722 l
+0.2993 0.6712 l
+0.3000 0.6702 l
+0.3007 0.6692 l
+0.3013 0.6682 l
+0.3020 0.6673 l
+0.3027 0.6663 l
+0.3033 0.6653 l
+0.3040 0.6643 l
+0.3047 0.6633 l
+0.3053 0.6624 l
+0.3060 0.6614 l
+0.3067 0.6604 l
+0.3073 0.6595 l
+0.3080 0.6585 l
+0.3087 0.6575 l
+0.3093 0.6566 l
+0.3100 0.6556 l
+0.3107 0.6546 l
+0.3113 0.6536 l
+0.3120 0.6526 l
+0.3127 0.6517 l
+0.3133 0.6507 l
+0.3140 0.6498 l
+0.3147 0.6489 l
+0.3153 0.6479 l
+0.3160 0.6470 l
+0.3167 0.6461 l
+0.3173 0.6452 l
+0.3180 0.6442 l
+0.3187 0.6433 l
+0.3193 0.6424 l
+0.3200 0.6415 l
+0.3207 0.6407 l
+0.3213 0.6398 l
+0.3220 0.6389 l
+0.3227 0.6380 l
+0.3233 0.6371 l
+0.3240 0.6362 l
+0.3247 0.6353 l
+0.3253 0.6344 l
+0.3260 0.6335 l
+0.3267 0.6327 l
+0.3273 0.6318 l
+0.3280 0.6310 l
+0.3287 0.6301 l
+0.3293 0.6293 l
+0.3300 0.6284 l
+0.3307 0.6276 l
+0.3313 0.6267 l
+0.3320 0.6259 l
+0.3327 0.6251 l
+0.3333 0.6243 l
+0.3340 0.6235 l
+0.3347 0.6227 l
+0.3353 0.6219 l
+0.3360 0.6211 l
+0.3367 0.6203 l
+0.3373 0.6195 l
+0.3380 0.6188 l
+0.3387 0.6180 l
+0.3393 0.6172 l
+0.3400 0.6165 l
+0.3407 0.6157 l
+0.3413 0.6150 l
+0.3420 0.6142 l
+0.3427 0.6135 l
+0.3433 0.6127 l
+0.3440 0.6120 l
+0.3447 0.6112 l
+0.3453 0.6105 l
+0.3460 0.6098 l
+0.3467 0.6090 l
+0.3473 0.6083 l
+0.3480 0.6076 l
+0.3487 0.6069 l
+0.3493 0.6062 l
+0.3500 0.6055 l
+0.3507 0.6048 l
+0.3513 0.6040 l
+0.3520 0.6033 l
+0.3527 0.6026 l
+0.3533 0.6020 l
+0.3540 0.6013 l
+0.3547 0.6006 l
+0.3553 0.5999 l
+0.3560 0.5993 l
+0.3567 0.5986 l
+0.3573 0.5980 l
+0.3580 0.5973 l
+0.3587 0.5967 l
+0.3593 0.5961 l
+0.3600 0.5954 l
+0.3607 0.5948 l
+0.3613 0.5942 l
+0.3620 0.5935 l
+0.3627 0.5929 l
+0.3633 0.5923 l
+0.3640 0.5917 l
+0.3647 0.5911 l
+0.3653 0.5905 l
+0.3660 0.5899 l
+0.3667 0.5893 l
+0.3673 0.5888 l
+0.3680 0.5882 l
+0.3687 0.5876 l
+0.3693 0.5870 l
+0.3700 0.5864 l
+0.3707 0.5859 l
+0.3713 0.5853 l
+0.3720 0.5848 l
+0.3727 0.5842 l
+0.3733 0.5837 l
+0.3740 0.5832 l
+0.3747 0.5826 l
+0.3753 0.5821 l
+0.3760 0.5816 l
+0.3767 0.5810 l
+0.3773 0.5805 l
+0.3780 0.5800 l
+0.3787 0.5795 l
+0.3793 0.5790 l
+0.3800 0.5785 l
+0.3807 0.5780 l
+0.3813 0.5775 l
+0.3820 0.5770 l
+0.3827 0.5766 l
+0.3833 0.5761 l
+0.3840 0.5756 l
+0.3847 0.5751 l
+0.3853 0.5747 l
+0.3860 0.5742 l
+0.3867 0.5737 l
+0.3873 0.5733 l
+0.3880 0.5728 l
+0.3887 0.5724 l
+0.3893 0.5719 l
+0.3900 0.5715 l
+0.3907 0.5711 l
+0.3913 0.5706 l
+0.3920 0.5702 l
+0.3927 0.5698 l
+0.3933 0.5694 l
+0.3940 0.5690 l
+0.3947 0.5686 l
+0.3953 0.5682 l
+0.3960 0.5678 l
+0.3967 0.5674 l
+0.3973 0.5670 l
+0.3980 0.5666 l
+0.3987 0.5662 l
+0.3993 0.5658 l
+0.4000 0.5655 l
+0.4007 0.5651 l
+0.4013 0.5647 l
+0.4020 0.5644 l
+0.4027 0.5640 l
+0.4033 0.5637 l
+0.4040 0.5633 l
+0.4047 0.5629 l
+0.4053 0.5626 l
+0.4060 0.5622 l
+0.4067 0.5619 l
+0.4073 0.5616 l
+0.4080 0.5612 l
+0.4087 0.5609 l
+0.4093 0.5606 l
+0.4100 0.5602 l
+0.4107 0.5599 l
+0.4113 0.5596 l
+0.4120 0.5593 l
+0.4127 0.5590 l
+0.4133 0.5586 l
+0.4140 0.5583 l
+0.4147 0.5580 l
+0.4153 0.5577 l
+0.4160 0.5574 l
+0.4167 0.5571 l
+0.4173 0.5568 l
+0.4180 0.5565 l
+0.4187 0.5562 l
+0.4193 0.5559 l
+0.4200 0.5556 l
+0.4207 0.5553 l
+0.4213 0.5550 l
+0.4220 0.5547 l
+0.4227 0.5544 l
+0.4233 0.5541 l
+0.4240 0.5538 l
+0.4247 0.5535 l
+0.4253 0.5533 l
+0.4260 0.5530 l
+0.4267 0.5527 l
+0.4273 0.5524 l
+0.4280 0.5521 l
+0.4287 0.5518 l
+0.4293 0.5516 l
+0.4300 0.5513 l
+0.4307 0.5510 l
+0.4313 0.5508 l
+0.4320 0.5505 l
+0.4327 0.5502 l
+0.4333 0.5500 l
+0.4340 0.5497 l
+0.4347 0.5494 l
+0.4353 0.5492 l
+0.4360 0.5489 l
+0.4367 0.5486 l
+0.4373 0.5484 l
+0.4380 0.5481 l
+0.4387 0.5478 l
+0.4393 0.5476 l
+0.4400 0.5473 l
+0.4407 0.5471 l
+0.4413 0.5468 l
+0.4420 0.5466 l
+0.4427 0.5463 l
+0.4433 0.5461 l
+0.4440 0.5458 l
+0.4447 0.5456 l
+0.4453 0.5453 l
+0.4460 0.5451 l
+0.4467 0.5448 l
+0.4473 0.5446 l
+0.4480 0.5443 l
+0.4487 0.5441 l
+0.4493 0.5439 l
+0.4500 0.5436 l
+0.4507 0.5434 l
+0.4513 0.5432 l
+0.4520 0.5429 l
+0.4527 0.5427 l
+0.4533 0.5425 l
+0.4540 0.5422 l
+0.4547 0.5420 l
+0.4553 0.5418 l
+0.4560 0.5416 l
+0.4567 0.5413 l
+0.4573 0.5411 l
+0.4580 0.5409 l
+0.4587 0.5407 l
+0.4593 0.5405 l
+0.4600 0.5402 l
+0.4607 0.5400 l
+0.4613 0.5398 l
+0.4620 0.5396 l
+0.4627 0.5394 l
+0.4633 0.5392 l
+0.4640 0.5390 l
+0.4647 0.5388 l
+0.4653 0.5386 l
+0.4660 0.5383 l
+0.4667 0.5381 l
+0.4673 0.5379 l
+0.4680 0.5377 l
+0.4687 0.5375 l
+0.4693 0.5373 l
+0.4700 0.5371 l
+0.4707 0.5369 l
+0.4713 0.5367 l
+0.4720 0.5365 l
+0.4727 0.5363 l
+0.4733 0.5361 l
+0.4740 0.5359 l
+0.4747 0.5358 l
+0.4753 0.5356 l
+0.4760 0.5354 l
+0.4767 0.5352 l
+0.4773 0.5350 l
+0.4780 0.5348 l
+0.4787 0.5346 l
+0.4793 0.5344 l
+0.4800 0.5342 l
+0.4807 0.5341 l
+0.4813 0.5339 l
+0.4820 0.5337 l
+0.4827 0.5335 l
+0.4833 0.5333 l
+0.4840 0.5331 l
+0.4847 0.5330 l
+0.4853 0.5328 l
+0.4860 0.5326 l
+0.4867 0.5324 l
+0.4873 0.5322 l
+0.4880 0.5321 l
+0.4887 0.5319 l
+0.4893 0.5317 l
+0.4900 0.5315 l
+0.4907 0.5314 l
+0.4913 0.5312 l
+0.4920 0.5310 l
+0.4927 0.5309 l
+0.4933 0.5307 l
+0.4940 0.5305 l
+0.4947 0.5304 l
+0.4953 0.5302 l
+0.4960 0.5300 l
+0.4967 0.5299 l
+0.4973 0.5297 l
+0.4980 0.5295 l
+0.4987 0.5294 l
+0.4993 0.5292 l
+0.5000 0.5290 l
+0.5007 0.5289 l
+0.5013 0.5287 l
+0.5020 0.5285 l
+0.5027 0.5284 l
+0.5033 0.5282 l
+0.5040 0.5281 l
+0.5047 0.5279 l
+0.5053 0.5278 l
+0.5060 0.5276 l
+0.5067 0.5274 l
+0.5073 0.5273 l
+0.5080 0.5272 l
+0.5087 0.5271 l
+0.5093 0.5270 l
+0.5100 0.5268 l
+0.5107 0.5267 l
+0.5113 0.5266 l
+0.5120 0.5265 l
+0.5127 0.5264 l
+0.5133 0.5262 l
+0.5140 0.5261 l
+0.5147 0.5260 l
+0.5153 0.5259 l
+0.5160 0.5258 l
+0.5167 0.5257 l
+0.5173 0.5255 l
+0.5180 0.5254 l
+0.5187 0.5253 l
+0.5193 0.5252 l
+0.5200 0.5251 l
+0.5207 0.5250 l
+0.5213 0.5249 l
+0.5220 0.5247 l
+0.5227 0.5246 l
+0.5233 0.5245 l
+0.5240 0.5244 l
+0.5247 0.5243 l
+0.5253 0.5242 l
+0.5260 0.5241 l
+0.5267 0.5240 l
+0.5273 0.5239 l
+0.5280 0.5237 l
+0.5287 0.5236 l
+0.5293 0.5235 l
+0.5300 0.5234 l
+0.5307 0.5233 l
+0.5313 0.5232 l
+0.5320 0.5231 l
+0.5327 0.5230 l
+0.5333 0.5229 l
+0.5340 0.5228 l
+0.5347 0.5227 l
+0.5353 0.5225 l
+0.5360 0.5224 l
+0.5367 0.5223 l
+0.5373 0.5222 l
+0.5380 0.5221 l
+0.5387 0.5220 l
+0.5393 0.5219 l
+0.5400 0.5218 l
+0.5407 0.5217 l
+0.5413 0.5216 l
+0.5420 0.5215 l
+0.5427 0.5214 l
+0.5433 0.5213 l
+0.5440 0.5212 l
+0.5447 0.5211 l
+0.5453 0.5210 l
+0.5460 0.5209 l
+0.5467 0.5208 l
+0.5473 0.5207 l
+0.5480 0.5206 l
+0.5487 0.5205 l
+0.5493 0.5204 l
+0.5500 0.5203 l
+0.5507 0.5202 l
+0.5513 0.5201 l
+0.5520 0.5200 l
+0.5527 0.5199 l
+0.5533 0.5198 l
+0.5540 0.5197 l
+0.5547 0.5196 l
+0.5553 0.5195 l
+0.5560 0.5194 l
+0.5567 0.5193 l
+0.5573 0.5192 l
+0.5580 0.5191 l
+0.5587 0.5190 l
+0.5593 0.5189 l
+0.5600 0.5188 l
+0.5607 0.5187 l
+0.5613 0.5186 l
+0.5620 0.5185 l
+0.5627 0.5184 l
+0.5633 0.5183 l
+0.5640 0.5182 l
+0.5647 0.5181 l
+0.5653 0.5180 l
+0.5660 0.5180 l
+0.5667 0.5179 l
+0.5673 0.5178 l
+0.5680 0.5177 l
+0.5687 0.5176 l
+0.5693 0.5175 l
+0.5700 0.5174 l
+0.5707 0.5173 l
+0.5713 0.5172 l
+0.5720 0.5171 l
+0.5727 0.5170 l
+0.5733 0.5169 l
+0.5740 0.5169 l
+0.5747 0.5168 l
+0.5753 0.5167 l
+0.5760 0.5166 l
+0.5767 0.5165 l
+0.5773 0.5164 l
+0.5780 0.5163 l
+0.5787 0.5162 l
+0.5793 0.5161 l
+0.5800 0.5161 l
+0.5807 0.5160 l
+0.5813 0.5159 l
+0.5820 0.5158 l
+0.5827 0.5157 l
+0.5833 0.5156 l
+0.5840 0.5156 l
+0.5847 0.5155 l
+0.5853 0.5154 l
+0.5860 0.5153 l
+0.5867 0.5152 l
+0.5873 0.5152 l
+0.5880 0.5151 l
+0.5887 0.5150 l
+0.5893 0.5149 l
+0.5900 0.5148 l
+0.5907 0.5148 l
+0.5913 0.5147 l
+0.5920 0.5146 l
+0.5927 0.5145 l
+0.5933 0.5145 l
+0.5940 0.5144 l
+0.5947 0.5143 l
+0.5953 0.5143 l
+0.5960 0.5142 l
+0.5967 0.5141 l
+0.5973 0.5140 l
+0.5980 0.5140 l
+0.5987 0.5139 l
+0.5993 0.5138 l
+0.6000 0.5137 l
+0.6007 0.5137 l
+0.6013 0.5136 l
+0.6020 0.5135 l
+0.6027 0.5135 l
+0.6033 0.5134 l
+0.6040 0.5133 l
+0.6047 0.5133 l
+0.6053 0.5132 l
+0.6060 0.5131 l
+0.6067 0.5130 l
+0.6073 0.5130 l
+0.6080 0.5129 l
+0.6087 0.5128 l
+0.6093 0.5128 l
+0.6100 0.5127 l
+0.6107 0.5126 l
+0.6113 0.5126 l
+0.6120 0.5125 l
+0.6127 0.5124 l
+0.6133 0.5124 l
+0.6140 0.5123 l
+0.6147 0.5122 l
+0.6153 0.5121 l
+0.6160 0.5121 l
+0.6167 0.5120 l
+0.6173 0.5119 l
+0.6180 0.5119 l
+0.6187 0.5118 l
+0.6193 0.5117 l
+0.6200 0.5117 l
+0.6207 0.5116 l
+0.6213 0.5115 l
+0.6220 0.5115 l
+0.6227 0.5114 l
+0.6233 0.5113 l
+0.6240 0.5113 l
+0.6247 0.5112 l
+0.6253 0.5111 l
+0.6260 0.5111 l
+0.6267 0.5110 l
+0.6273 0.5109 l
+0.6280 0.5109 l
+0.6287 0.5108 l
+0.6293 0.5107 l
+0.6300 0.5107 l
+0.6307 0.5106 l
+0.6313 0.5105 l
+0.6320 0.5105 l
+0.6327 0.5104 l
+0.6333 0.5103 l
+0.6340 0.5103 l
+0.6347 0.5102 l
+0.6353 0.5101 l
+0.6360 0.5101 l
+0.6367 0.5100 l
+0.6373 0.5099 l
+0.6380 0.5099 l
+0.6387 0.5098 l
+0.6393 0.5098 l
+0.6400 0.5097 l
+0.6407 0.5096 l
+0.6413 0.5096 l
+0.6420 0.5095 l
+0.6427 0.5094 l
+0.6433 0.5094 l
+0.6440 0.5093 l
+0.6447 0.5092 l
+0.6453 0.5092 l
+0.6460 0.5091 l
+0.6467 0.5091 l
+0.6473 0.5090 l
+0.6480 0.5089 l
+0.6487 0.5089 l
+0.6493 0.5088 l
+0.6500 0.5087 l
+0.6507 0.5087 l
+0.6513 0.5086 l
+0.6520 0.5086 l
+0.6527 0.5085 l
+0.6533 0.5084 l
+0.6540 0.5084 l
+0.6547 0.5083 l
+0.6553 0.5082 l
+0.6560 0.5082 l
+0.6567 0.5081 l
+0.6573 0.5081 l
+0.6580 0.5080 l
+0.6587 0.5079 l
+0.6593 0.5079 l
+0.6600 0.5078 l
+0.6607 0.5078 l
+0.6613 0.5077 l
+0.6620 0.5076 l
+0.6627 0.5076 l
+0.6633 0.5075 l
+0.6640 0.5075 l
+0.6647 0.5074 l
+0.6653 0.5073 l
+0.6660 0.5073 l
+0.6667 0.5072 l
+0.6673 0.5072 l
+0.6680 0.5071 l
+0.6687 0.5070 l
+0.6693 0.5070 l
+0.6700 0.5069 l
+0.6707 0.5069 l
+0.6713 0.5068 l
+0.6720 0.5067 l
+0.6727 0.5067 l
+0.6733 0.5066 l
+0.6740 0.5066 l
+0.6747 0.5065 l
+0.6753 0.5065 l
+0.6760 0.5064 l
+0.6767 0.5063 l
+0.6773 0.5063 l
+0.6780 0.5062 l
+0.6787 0.5062 l
+0.6793 0.5061 l
+0.6800 0.5061 l
+0.6807 0.5060 l
+0.6813 0.5059 l
+0.6820 0.5059 l
+0.6827 0.5058 l
+0.6833 0.5058 l
+0.6840 0.5057 l
+0.6847 0.5057 l
+0.6853 0.5056 l
+0.6860 0.5056 l
+0.6867 0.5055 l
+0.6873 0.5054 l
+0.6880 0.5054 l
+0.6887 0.5053 l
+0.6893 0.5053 l
+0.6900 0.5052 l
+0.6907 0.5052 l
+0.6913 0.5051 l
+0.6920 0.5051 l
+0.6927 0.5050 l
+0.6933 0.5050 l
+0.6940 0.5049 l
+0.6947 0.5049 l
+0.6953 0.5048 l
+0.6960 0.5048 l
+0.6967 0.5047 l
+0.6973 0.5047 l
+0.6980 0.5046 l
+0.6987 0.5046 l
+0.6993 0.5045 l
+0.7000 0.5045 l
+0.7007 0.5044 l
+0.7013 0.5044 l
+0.7020 0.5043 l
+0.7027 0.5043 l
+0.7033 0.5042 l
+0.7040 0.5042 l
+0.7047 0.5041 l
+0.7053 0.5041 l
+0.7060 0.5040 l
+0.7067 0.5040 l
+0.7073 0.5039 l
+0.7080 0.5039 l
+0.7087 0.5038 l
+0.7093 0.5038 l
+0.7100 0.5037 l
+0.7107 0.5037 l
+0.7113 0.5036 l
+0.7120 0.5036 l
+0.7127 0.5035 l
+0.7133 0.5035 l
+0.7140 0.5035 l
+0.7147 0.5034 l
+0.7153 0.5034 l
+0.7160 0.5033 l
+0.7167 0.5033 l
+0.7173 0.5032 l
+0.7180 0.5032 l
+0.7187 0.5031 l
+0.7193 0.5031 l
+0.7200 0.5030 l
+0.7207 0.5030 l
+0.7213 0.5030 l
+0.7220 0.5029 l
+0.7227 0.5029 l
+0.7233 0.5028 l
+0.7240 0.5028 l
+0.7247 0.5027 l
+0.7253 0.5027 l
+0.7260 0.5027 l
+0.7267 0.5026 l
+0.7273 0.5026 l
+0.7280 0.5025 l
+0.7287 0.5025 l
+0.7293 0.5025 l
+0.7300 0.5024 l
+0.7307 0.5024 l
+0.7313 0.5023 l
+0.7320 0.5023 l
+0.7327 0.5023 l
+0.7333 0.5022 l
+0.7340 0.5022 l
+0.7347 0.5021 l
+0.7353 0.5021 l
+0.7360 0.5021 l
+0.7367 0.5020 l
+0.7373 0.5020 l
+0.7380 0.5019 l
+0.7387 0.5019 l
+0.7393 0.5019 l
+0.7400 0.5018 l
+0.7407 0.5018 l
+0.7413 0.5018 l
+0.7420 0.5017 l
+0.7427 0.5017 l
+0.7433 0.5017 l
+0.7440 0.5016 l
+0.7447 0.5016 l
+0.7453 0.5015 l
+0.7460 0.5015 l
+0.7467 0.5015 l
+0.7473 0.5014 l
+0.7480 0.5014 l
+0.7487 0.5014 l
+0.7493 0.5013 l
+0.7500 0.5013 l
+0.7507 0.5013 l
+0.7513 0.5012 l
+0.7520 0.5012 l
+0.7527 0.5012 l
+0.7533 0.5011 l
+0.7540 0.5011 l
+0.7547 0.5011 l
+0.7553 0.5010 l
+0.7560 0.5010 l
+0.7567 0.5010 l
+0.7573 0.5010 l
+0.7580 0.5009 l
+0.7587 0.5009 l
+0.7593 0.5009 l
+0.7600 0.5008 l
+0.7607 0.5008 l
+0.7613 0.5008 l
+0.7620 0.5007 l
+0.7627 0.5007 l
+0.7633 0.5007 l
+0.7640 0.5007 l
+0.7647 0.5006 l
+0.7653 0.5006 l
+0.7660 0.5006 l
+0.7667 0.5005 l
+0.7673 0.5005 l
+0.7680 0.5005 l
+0.7687 0.5005 l
+0.7693 0.5004 l
+0.7700 0.5004 l
+0.7707 0.5004 l
+0.7713 0.5004 l
+0.7720 0.5003 l
+0.7727 0.5003 l
+0.7733 0.5003 l
+0.7740 0.5003 l
+0.7747 0.5002 l
+0.7753 0.5002 l
+0.7760 0.5002 l
+0.7767 0.5002 l
+0.7773 0.5001 l
+0.7780 0.5001 l
+0.7787 0.5001 l
+0.7793 0.5001 l
+0.7800 0.5000 l
+0.7807 0.5000 l
+0.7813 0.5000 l
+0.7820 0.5000 l
+0.7827 0.4999 l
+0.7833 0.4999 l
+0.7840 0.4999 l
+0.7847 0.4999 l
+0.7853 0.4998 l
+0.7860 0.4998 l
+0.7867 0.4998 l
+0.7873 0.4998 l
+0.7880 0.4998 l
+0.7887 0.4997 l
+0.7893 0.4997 l
+0.7900 0.4997 l
+0.7907 0.4997 l
+0.7913 0.4997 l
+0.7920 0.4996 l
+0.7927 0.4996 l
+0.7933 0.4996 l
+0.7940 0.4996 l
+0.7947 0.4996 l
+0.7953 0.4995 l
+0.7960 0.4995 l
+0.7967 0.4995 l
+0.7973 0.4995 l
+0.7980 0.4995 l
+0.7987 0.4994 l
+0.7993 0.4994 l
+0.8000 0.4994 l
+0.8007 0.4994 l
+0.8013 0.4994 l
+0.8020 0.4993 l
+0.8027 0.4993 l
+0.8033 0.4993 l
+0.8040 0.4993 l
+0.8047 0.4993 l
+0.8053 0.4993 l
+0.8060 0.4992 l
+0.8067 0.4992 l
+0.8073 0.4992 l
+0.8080 0.4992 l
+0.8087 0.4992 l
+0.8093 0.4991 l
+0.8100 0.4991 l
+0.8107 0.4991 l
+0.8113 0.4991 l
+0.8120 0.4991 l
+0.8127 0.4991 l
+0.8133 0.4990 l
+0.8140 0.4990 l
+0.8147 0.4990 l
+0.8153 0.4990 l
+0.8160 0.4990 l
+s
+n
+0.1500 0.1936 m
+0.1507 0.1946 l
+0.1513 0.1957 l
+0.1520 0.1967 l
+0.1527 0.1978 l
+0.1533 0.1989 l
+0.1540 0.2000 l
+0.1547 0.2011 l
+0.1553 0.2021 l
+0.1560 0.2031 l
+0.1567 0.2042 l
+0.1573 0.2052 l
+0.1580 0.2063 l
+0.1587 0.2074 l
+0.1593 0.2085 l
+0.1600 0.2095 l
+0.1607 0.2106 l
+0.1613 0.2117 l
+0.1620 0.2128 l
+0.1627 0.2139 l
+0.1633 0.2148 l
+0.1640 0.2159 l
+0.1647 0.2169 l
+0.1653 0.2179 l
+0.1660 0.2189 l
+0.1667 0.2200 l
+0.1673 0.2208 l
+0.1680 0.2217 l
+0.1687 0.2226 l
+0.1693 0.2235 l
+0.1700 0.2243 l
+0.1707 0.2250 l
+0.1713 0.2257 l
+0.1720 0.2265 l
+0.1727 0.2272 l
+0.1733 0.2280 l
+0.1740 0.2286 l
+0.1747 0.2293 l
+0.1753 0.2301 l
+0.1760 0.2308 l
+0.1767 0.2315 l
+0.1773 0.2322 l
+0.1780 0.2330 l
+0.1787 0.2337 l
+0.1793 0.2344 l
+0.1800 0.2352 l
+0.1807 0.2359 l
+0.1813 0.2367 l
+0.1820 0.2376 l
+0.1827 0.2383 l
+0.1833 0.2391 l
+0.1840 0.2399 l
+0.1847 0.2407 l
+0.1853 0.2416 l
+0.1860 0.2425 l
+0.1867 0.2434 l
+0.1873 0.2442 l
+0.1880 0.2450 l
+0.1887 0.2457 l
+0.1893 0.2463 l
+0.1900 0.2468 l
+0.1907 0.2472 l
+0.1913 0.2475 l
+0.1920 0.2478 l
+0.1927 0.2482 l
+0.1933 0.2485 l
+0.1940 0.2489 l
+0.1947 0.2492 l
+0.1953 0.2496 l
+0.1960 0.2500 l
+0.1967 0.2504 l
+0.1973 0.2507 l
+0.1980 0.2511 l
+0.1987 0.2515 l
+0.1993 0.2519 l
+0.2000 0.2523 l
+0.2007 0.2527 l
+0.2013 0.2532 l
+0.2020 0.2536 l
+0.2027 0.2540 l
+0.2033 0.2544 l
+0.2040 0.2549 l
+0.2047 0.2553 l
+0.2053 0.2557 l
+0.2060 0.2561 l
+0.2067 0.2565 l
+0.2073 0.2569 l
+0.2080 0.2573 l
+0.2087 0.2577 l
+0.2093 0.2580 l
+0.2100 0.2584 l
+0.2107 0.2588 l
+0.2113 0.2592 l
+0.2120 0.2597 l
+0.2127 0.2601 l
+0.2133 0.2605 l
+0.2140 0.2609 l
+0.2147 0.2614 l
+0.2153 0.2618 l
+0.2160 0.2623 l
+0.2167 0.2627 l
+0.2173 0.2632 l
+0.2180 0.2637 l
+0.2187 0.2641 l
+0.2193 0.2646 l
+0.2200 0.2651 l
+0.2207 0.2656 l
+0.2213 0.2659 l
+0.2220 0.2662 l
+0.2227 0.2666 l
+0.2233 0.2669 l
+0.2240 0.2672 l
+0.2247 0.2676 l
+0.2253 0.2680 l
+0.2260 0.2684 l
+0.2267 0.2687 l
+0.2273 0.2691 l
+0.2280 0.2695 l
+0.2287 0.2699 l
+0.2293 0.2704 l
+0.2300 0.2708 l
+0.2307 0.2712 l
+0.2313 0.2717 l
+0.2320 0.2722 l
+0.2327 0.2726 l
+0.2333 0.2731 l
+0.2340 0.2736 l
+0.2347 0.2741 l
+0.2353 0.2747 l
+0.2360 0.2752 l
+0.2367 0.2757 l
+0.2373 0.2763 l
+0.2380 0.2768 l
+0.2387 0.2774 l
+0.2393 0.2780 l
+0.2400 0.2785 l
+0.2407 0.2790 l
+0.2413 0.2794 l
+0.2420 0.2799 l
+0.2427 0.2803 l
+0.2433 0.2808 l
+0.2440 0.2812 l
+0.2447 0.2817 l
+0.2453 0.2822 l
+0.2460 0.2827 l
+0.2467 0.2831 l
+0.2473 0.2836 l
+0.2480 0.2841 l
+0.2487 0.2846 l
+0.2493 0.2851 l
+0.2500 0.2856 l
+0.2507 0.2861 l
+0.2513 0.2866 l
+0.2520 0.2871 l
+0.2527 0.2876 l
+0.2533 0.2881 l
+0.2540 0.2886 l
+0.2547 0.2891 l
+0.2553 0.2897 l
+0.2560 0.2902 l
+0.2567 0.2907 l
+0.2573 0.2913 l
+0.2580 0.2918 l
+0.2587 0.2923 l
+0.2593 0.2929 l
+0.2600 0.2934 l
+0.2607 0.2939 l
+0.2613 0.2945 l
+0.2620 0.2950 l
+0.2627 0.2956 l
+0.2633 0.2961 l
+0.2640 0.2967 l
+0.2647 0.2973 l
+0.2653 0.2978 l
+0.2660 0.2984 l
+0.2667 0.2990 l
+0.2673 0.2995 l
+0.2680 0.3001 l
+0.2687 0.3007 l
+0.2693 0.3013 l
+0.2700 0.3018 l
+0.2707 0.3024 l
+0.2713 0.3030 l
+0.2720 0.3036 l
+0.2727 0.3042 l
+0.2733 0.3048 l
+0.2740 0.3054 l
+0.2747 0.3060 l
+0.2753 0.3066 l
+0.2760 0.3072 l
+0.2767 0.3078 l
+0.2773 0.3084 l
+0.2780 0.3090 l
+0.2787 0.3096 l
+0.2793 0.3103 l
+0.2800 0.3109 l
+0.2807 0.3115 l
+0.2813 0.3121 l
+0.2820 0.3128 l
+0.2827 0.3134 l
+0.2833 0.3140 l
+0.2840 0.3146 l
+0.2847 0.3153 l
+0.2853 0.3159 l
+0.2860 0.3166 l
+0.2867 0.3172 l
+0.2873 0.3179 l
+0.2880 0.3185 l
+0.2887 0.3192 l
+0.2893 0.3198 l
+0.2900 0.3205 l
+0.2907 0.3211 l
+0.2913 0.3218 l
+0.2920 0.3224 l
+0.2927 0.3231 l
+0.2933 0.3238 l
+0.2940 0.3244 l
+0.2947 0.3251 l
+0.2953 0.3258 l
+0.2960 0.3265 l
+0.2967 0.3271 l
+0.2973 0.3278 l
+0.2980 0.3285 l
+0.2987 0.3292 l
+0.2993 0.3299 l
+0.3000 0.3306 l
+0.3007 0.3313 l
+0.3013 0.3320 l
+0.3020 0.3327 l
+0.3027 0.3334 l
+0.3033 0.3341 l
+0.3040 0.3348 l
+0.3047 0.3355 l
+0.3053 0.3362 l
+0.3060 0.3369 l
+0.3067 0.3376 l
+0.3073 0.3383 l
+0.3080 0.3391 l
+0.3087 0.3398 l
+0.3093 0.3405 l
+0.3100 0.3412 l
+0.3107 0.3419 l
+0.3113 0.3426 l
+0.3120 0.3433 l
+0.3127 0.3440 l
+0.3133 0.3448 l
+0.3140 0.3455 l
+0.3147 0.3462 l
+0.3153 0.3469 l
+0.3160 0.3476 l
+0.3167 0.3483 l
+0.3173 0.3490 l
+0.3180 0.3498 l
+0.3187 0.3505 l
+0.3193 0.3512 l
+0.3200 0.3519 l
+0.3207 0.3526 l
+0.3213 0.3533 l
+0.3220 0.3540 l
+0.3227 0.3548 l
+0.3233 0.3555 l
+0.3240 0.3562 l
+0.3247 0.3569 l
+0.3253 0.3576 l
+0.3260 0.3583 l
+0.3267 0.3590 l
+0.3273 0.3597 l
+0.3280 0.3604 l
+0.3287 0.3611 l
+0.3293 0.3618 l
+0.3300 0.3625 l
+0.3307 0.3632 l
+0.3313 0.3639 l
+0.3320 0.3646 l
+0.3327 0.3653 l
+0.3333 0.3660 l
+0.3340 0.3666 l
+0.3347 0.3673 l
+0.3353 0.3680 l
+0.3360 0.3687 l
+0.3367 0.3694 l
+0.3373 0.3700 l
+0.3380 0.3707 l
+0.3387 0.3714 l
+0.3393 0.3720 l
+0.3400 0.3727 l
+0.3407 0.3734 l
+0.3413 0.3740 l
+0.3420 0.3747 l
+0.3427 0.3753 l
+0.3433 0.3760 l
+0.3440 0.3766 l
+0.3447 0.3773 l
+0.3453 0.3779 l
+0.3460 0.3786 l
+0.3467 0.3792 l
+0.3473 0.3798 l
+0.3480 0.3805 l
+0.3487 0.3811 l
+0.3493 0.3817 l
+0.3500 0.3824 l
+0.3507 0.3830 l
+0.3513 0.3836 l
+0.3520 0.3842 l
+0.3527 0.3849 l
+0.3533 0.3855 l
+0.3540 0.3861 l
+0.3547 0.3867 l
+0.3553 0.3873 l
+0.3560 0.3879 l
+0.3567 0.3885 l
+0.3573 0.3891 l
+0.3580 0.3897 l
+0.3587 0.3903 l
+0.3593 0.3909 l
+0.3600 0.3915 l
+0.3607 0.3920 l
+0.3613 0.3926 l
+0.3620 0.3932 l
+0.3627 0.3938 l
+0.3633 0.3943 l
+0.3640 0.3949 l
+0.3647 0.3955 l
+0.3653 0.3960 l
+0.3660 0.3966 l
+0.3667 0.3971 l
+0.3673 0.3977 l
+0.3680 0.3982 l
+0.3687 0.3987 l
+0.3693 0.3993 l
+0.3700 0.3998 l
+0.3707 0.4003 l
+0.3713 0.4009 l
+0.3720 0.4014 l
+0.3727 0.4019 l
+0.3733 0.4024 l
+0.3740 0.4029 l
+0.3747 0.4035 l
+0.3753 0.4040 l
+0.3760 0.4045 l
+0.3767 0.4050 l
+0.3773 0.4055 l
+0.3780 0.4060 l
+0.3787 0.4065 l
+0.3793 0.4070 l
+0.3800 0.4075 l
+0.3807 0.4079 l
+0.3813 0.4084 l
+0.3820 0.4089 l
+0.3827 0.4094 l
+0.3833 0.4099 l
+0.3840 0.4103 l
+0.3847 0.4108 l
+0.3853 0.4113 l
+0.3860 0.4118 l
+0.3867 0.4122 l
+0.3873 0.4127 l
+0.3880 0.4132 l
+0.3887 0.4136 l
+0.3893 0.4141 l
+0.3900 0.4145 l
+0.3907 0.4150 l
+0.3913 0.4154 l
+0.3920 0.4159 l
+0.3927 0.4163 l
+0.3933 0.4168 l
+0.3940 0.4172 l
+0.3947 0.4177 l
+0.3953 0.4181 l
+0.3960 0.4186 l
+0.3967 0.4190 l
+0.3973 0.4194 l
+0.3980 0.4199 l
+0.3987 0.4203 l
+0.3993 0.4207 l
+0.4000 0.4212 l
+0.4007 0.4216 l
+0.4013 0.4220 l
+0.4020 0.4224 l
+0.4027 0.4228 l
+0.4033 0.4233 l
+0.4040 0.4237 l
+0.4047 0.4241 l
+0.4053 0.4245 l
+0.4060 0.4249 l
+0.4067 0.4253 l
+0.4073 0.4257 l
+0.4080 0.4261 l
+0.4087 0.4265 l
+0.4093 0.4269 l
+0.4100 0.4273 l
+0.4107 0.4277 l
+0.4113 0.4281 l
+0.4120 0.4285 l
+0.4127 0.4289 l
+0.4133 0.4293 l
+0.4140 0.4297 l
+0.4147 0.4300 l
+0.4153 0.4304 l
+0.4160 0.4308 l
+0.4167 0.4312 l
+0.4173 0.4316 l
+0.4180 0.4320 l
+0.4187 0.4323 l
+0.4193 0.4327 l
+0.4200 0.4331 l
+0.4207 0.4334 l
+0.4213 0.4338 l
+0.4220 0.4342 l
+0.4227 0.4345 l
+0.4233 0.4349 l
+0.4240 0.4353 l
+0.4247 0.4356 l
+0.4253 0.4360 l
+0.4260 0.4364 l
+0.4267 0.4367 l
+0.4273 0.4371 l
+0.4280 0.4374 l
+0.4287 0.4378 l
+0.4293 0.4381 l
+0.4300 0.4385 l
+0.4307 0.4388 l
+0.4313 0.4391 l
+0.4320 0.4395 l
+0.4327 0.4398 l
+0.4333 0.4402 l
+0.4340 0.4405 l
+0.4347 0.4408 l
+0.4353 0.4411 l
+0.4360 0.4415 l
+0.4367 0.4418 l
+0.4373 0.4421 l
+0.4380 0.4424 l
+0.4387 0.4428 l
+0.4393 0.4431 l
+0.4400 0.4434 l
+0.4407 0.4437 l
+0.4413 0.4440 l
+0.4420 0.4444 l
+0.4427 0.4447 l
+0.4433 0.4450 l
+0.4440 0.4453 l
+0.4447 0.4456 l
+0.4453 0.4459 l
+0.4460 0.4462 l
+0.4467 0.4465 l
+0.4473 0.4468 l
+0.4480 0.4471 l
+0.4487 0.4474 l
+0.4493 0.4477 l
+0.4500 0.4480 l
+0.4507 0.4482 l
+0.4513 0.4485 l
+0.4520 0.4488 l
+0.4527 0.4491 l
+0.4533 0.4494 l
+0.4540 0.4496 l
+0.4547 0.4499 l
+0.4553 0.4502 l
+0.4560 0.4505 l
+0.4567 0.4507 l
+0.4573 0.4510 l
+0.4580 0.4512 l
+0.4587 0.4515 l
+0.4593 0.4518 l
+0.4600 0.4520 l
+0.4607 0.4523 l
+0.4613 0.4525 l
+0.4620 0.4528 l
+0.4627 0.4530 l
+0.4633 0.4533 l
+0.4640 0.4535 l
+0.4647 0.4538 l
+0.4653 0.4540 l
+0.4660 0.4543 l
+0.4667 0.4545 l
+0.4673 0.4547 l
+0.4680 0.4550 l
+0.4687 0.4552 l
+0.4693 0.4554 l
+0.4700 0.4557 l
+0.4707 0.4559 l
+0.4713 0.4561 l
+0.4720 0.4563 l
+0.4727 0.4566 l
+0.4733 0.4568 l
+0.4740 0.4570 l
+0.4747 0.4572 l
+0.4753 0.4574 l
+0.4760 0.4577 l
+0.4767 0.4579 l
+0.4773 0.4581 l
+0.4780 0.4583 l
+0.4787 0.4585 l
+0.4793 0.4587 l
+0.4800 0.4589 l
+0.4807 0.4591 l
+0.4813 0.4594 l
+0.4820 0.4596 l
+0.4827 0.4598 l
+0.4833 0.4600 l
+0.4840 0.4602 l
+0.4847 0.4604 l
+0.4853 0.4606 l
+0.4860 0.4608 l
+0.4867 0.4610 l
+0.4873 0.4612 l
+0.4880 0.4613 l
+0.4887 0.4615 l
+0.4893 0.4617 l
+0.4900 0.4619 l
+0.4907 0.4621 l
+0.4913 0.4623 l
+0.4920 0.4625 l
+0.4927 0.4627 l
+0.4933 0.4628 l
+0.4940 0.4630 l
+0.4947 0.4632 l
+0.4953 0.4634 l
+0.4960 0.4635 l
+0.4967 0.4637 l
+0.4973 0.4639 l
+0.4980 0.4641 l
+0.4987 0.4642 l
+0.4993 0.4644 l
+0.5000 0.4646 l
+0.5007 0.4647 l
+0.5013 0.4649 l
+0.5020 0.4651 l
+0.5027 0.4652 l
+0.5033 0.4654 l
+0.5040 0.4656 l
+0.5047 0.4657 l
+0.5053 0.4659 l
+0.5060 0.4661 l
+0.5067 0.4662 l
+0.5073 0.4664 l
+0.5080 0.4665 l
+0.5087 0.4667 l
+0.5093 0.4668 l
+0.5100 0.4670 l
+0.5107 0.4671 l
+0.5113 0.4673 l
+0.5120 0.4674 l
+0.5127 0.4676 l
+0.5133 0.4677 l
+0.5140 0.4678 l
+0.5147 0.4680 l
+0.5153 0.4681 l
+0.5160 0.4683 l
+0.5167 0.4684 l
+0.5173 0.4685 l
+0.5180 0.4687 l
+0.5187 0.4688 l
+0.5193 0.4689 l
+0.5200 0.4690 l
+0.5207 0.4692 l
+0.5213 0.4693 l
+0.5220 0.4694 l
+0.5227 0.4695 l
+0.5233 0.4696 l
+0.5240 0.4697 l
+0.5247 0.4698 l
+0.5253 0.4699 l
+0.5260 0.4700 l
+0.5267 0.4702 l
+0.5273 0.4703 l
+0.5280 0.4704 l
+0.5287 0.4705 l
+0.5293 0.4706 l
+0.5300 0.4707 l
+0.5307 0.4708 l
+0.5313 0.4709 l
+0.5320 0.4710 l
+0.5327 0.4711 l
+0.5333 0.4712 l
+0.5340 0.4713 l
+0.5347 0.4715 l
+0.5353 0.4716 l
+0.5360 0.4717 l
+0.5367 0.4718 l
+0.5373 0.4719 l
+0.5380 0.4720 l
+0.5387 0.4721 l
+0.5393 0.4722 l
+0.5400 0.4723 l
+0.5407 0.4724 l
+0.5413 0.4725 l
+0.5420 0.4726 l
+0.5427 0.4727 l
+0.5433 0.4728 l
+0.5440 0.4729 l
+0.5447 0.4730 l
+0.5453 0.4731 l
+0.5460 0.4732 l
+0.5467 0.4733 l
+0.5473 0.4734 l
+0.5480 0.4735 l
+0.5487 0.4736 l
+0.5493 0.4737 l
+0.5500 0.4738 l
+0.5507 0.4739 l
+0.5513 0.4740 l
+0.5520 0.4740 l
+0.5527 0.4741 l
+0.5533 0.4742 l
+0.5540 0.4743 l
+0.5547 0.4744 l
+0.5553 0.4745 l
+0.5560 0.4746 l
+0.5567 0.4747 l
+0.5573 0.4748 l
+0.5580 0.4749 l
+0.5587 0.4750 l
+0.5593 0.4751 l
+0.5600 0.4751 l
+0.5607 0.4752 l
+0.5613 0.4753 l
+0.5620 0.4754 l
+0.5627 0.4755 l
+0.5633 0.4756 l
+0.5640 0.4757 l
+0.5647 0.4758 l
+0.5653 0.4758 l
+0.5660 0.4759 l
+0.5667 0.4760 l
+0.5673 0.4761 l
+0.5680 0.4762 l
+0.5687 0.4763 l
+0.5693 0.4764 l
+0.5700 0.4764 l
+0.5707 0.4765 l
+0.5713 0.4766 l
+0.5720 0.4767 l
+0.5727 0.4768 l
+0.5733 0.4769 l
+0.5740 0.4770 l
+0.5747 0.4770 l
+0.5753 0.4771 l
+0.5760 0.4772 l
+0.5767 0.4773 l
+0.5773 0.4774 l
+0.5780 0.4775 l
+0.5787 0.4775 l
+0.5793 0.4776 l
+0.5800 0.4777 l
+0.5807 0.4778 l
+0.5813 0.4779 l
+0.5820 0.4780 l
+0.5827 0.4780 l
+0.5833 0.4781 l
+0.5840 0.4782 l
+0.5847 0.4783 l
+0.5853 0.4784 l
+0.5860 0.4785 l
+0.5867 0.4785 l
+0.5873 0.4786 l
+0.5880 0.4787 l
+0.5887 0.4788 l
+0.5893 0.4789 l
+0.5900 0.4789 l
+0.5907 0.4790 l
+0.5913 0.4791 l
+0.5920 0.4792 l
+0.5927 0.4793 l
+0.5933 0.4794 l
+0.5940 0.4794 l
+0.5947 0.4795 l
+0.5953 0.4796 l
+0.5960 0.4797 l
+0.5967 0.4798 l
+0.5973 0.4798 l
+0.5980 0.4799 l
+0.5987 0.4800 l
+0.5993 0.4801 l
+0.6000 0.4802 l
+0.6007 0.4802 l
+0.6013 0.4803 l
+0.6020 0.4804 l
+0.6027 0.4805 l
+0.6033 0.4805 l
+0.6040 0.4806 l
+0.6047 0.4807 l
+0.6053 0.4808 l
+0.6060 0.4809 l
+0.6067 0.4809 l
+0.6073 0.4810 l
+0.6080 0.4811 l
+0.6087 0.4812 l
+0.6093 0.4812 l
+0.6100 0.4813 l
+0.6107 0.4814 l
+0.6113 0.4815 l
+0.6120 0.4815 l
+0.6127 0.4816 l
+0.6133 0.4817 l
+0.6140 0.4818 l
+0.6147 0.4818 l
+0.6153 0.4819 l
+0.6160 0.4820 l
+0.6167 0.4821 l
+0.6173 0.4821 l
+0.6180 0.4822 l
+0.6187 0.4823 l
+0.6193 0.4824 l
+0.6200 0.4824 l
+0.6207 0.4825 l
+0.6213 0.4826 l
+0.6220 0.4826 l
+0.6227 0.4827 l
+0.6233 0.4828 l
+0.6240 0.4829 l
+0.6247 0.4829 l
+0.6253 0.4830 l
+0.6260 0.4831 l
+0.6267 0.4831 l
+0.6273 0.4832 l
+0.6280 0.4833 l
+0.6287 0.4834 l
+0.6293 0.4834 l
+0.6300 0.4835 l
+0.6307 0.4836 l
+0.6313 0.4836 l
+0.6320 0.4837 l
+0.6327 0.4838 l
+0.6333 0.4839 l
+0.6340 0.4839 l
+0.6347 0.4840 l
+0.6353 0.4841 l
+0.6360 0.4841 l
+0.6367 0.4842 l
+0.6373 0.4843 l
+0.6380 0.4843 l
+0.6387 0.4844 l
+0.6393 0.4845 l
+0.6400 0.4845 l
+0.6407 0.4846 l
+0.6413 0.4847 l
+0.6420 0.4847 l
+0.6427 0.4848 l
+0.6433 0.4849 l
+0.6440 0.4849 l
+0.6447 0.4850 l
+0.6453 0.4851 l
+0.6460 0.4851 l
+0.6467 0.4852 l
+0.6473 0.4853 l
+0.6480 0.4853 l
+0.6487 0.4854 l
+0.6493 0.4855 l
+0.6500 0.4855 l
+0.6507 0.4856 l
+0.6513 0.4857 l
+0.6520 0.4857 l
+0.6527 0.4858 l
+0.6533 0.4858 l
+0.6540 0.4859 l
+0.6547 0.4860 l
+0.6553 0.4860 l
+0.6560 0.4861 l
+0.6567 0.4862 l
+0.6573 0.4862 l
+0.6580 0.4863 l
+0.6587 0.4863 l
+0.6593 0.4864 l
+0.6600 0.4865 l
+0.6607 0.4865 l
+0.6613 0.4866 l
+0.6620 0.4867 l
+0.6627 0.4867 l
+0.6633 0.4868 l
+0.6640 0.4868 l
+0.6647 0.4869 l
+0.6653 0.4870 l
+0.6660 0.4870 l
+0.6667 0.4871 l
+0.6673 0.4871 l
+0.6680 0.4872 l
+0.6687 0.4873 l
+0.6693 0.4873 l
+0.6700 0.4874 l
+0.6707 0.4874 l
+0.6713 0.4875 l
+0.6720 0.4875 l
+0.6727 0.4876 l
+0.6733 0.4877 l
+0.6740 0.4877 l
+0.6747 0.4878 l
+0.6753 0.4878 l
+0.6760 0.4879 l
+0.6767 0.4880 l
+0.6773 0.4880 l
+0.6780 0.4881 l
+0.6787 0.4881 l
+0.6793 0.4882 l
+0.6800 0.4882 l
+0.6807 0.4883 l
+0.6813 0.4883 l
+0.6820 0.4884 l
+0.6827 0.4885 l
+0.6833 0.4885 l
+0.6840 0.4886 l
+0.6847 0.4886 l
+0.6853 0.4887 l
+0.6860 0.4887 l
+0.6867 0.4888 l
+0.6873 0.4888 l
+0.6880 0.4889 l
+0.6887 0.4889 l
+0.6893 0.4890 l
+0.6900 0.4891 l
+0.6907 0.4891 l
+0.6913 0.4892 l
+0.6920 0.4892 l
+0.6927 0.4893 l
+0.6933 0.4893 l
+0.6940 0.4894 l
+0.6947 0.4894 l
+0.6953 0.4895 l
+0.6960 0.4895 l
+0.6967 0.4896 l
+0.6973 0.4896 l
+0.6980 0.4897 l
+0.6987 0.4897 l
+0.6993 0.4898 l
+0.7000 0.4898 l
+0.7007 0.4899 l
+0.7013 0.4899 l
+0.7020 0.4900 l
+0.7027 0.4900 l
+0.7033 0.4901 l
+0.7040 0.4901 l
+0.7047 0.4902 l
+0.7053 0.4902 l
+0.7060 0.4903 l
+0.7067 0.4903 l
+0.7073 0.4904 l
+0.7080 0.4904 l
+0.7087 0.4905 l
+0.7093 0.4905 l
+0.7100 0.4905 l
+0.7107 0.4906 l
+0.7113 0.4906 l
+0.7120 0.4907 l
+0.7127 0.4907 l
+0.7133 0.4908 l
+0.7140 0.4908 l
+0.7147 0.4909 l
+0.7153 0.4909 l
+0.7160 0.4910 l
+0.7167 0.4910 l
+0.7173 0.4911 l
+0.7180 0.4911 l
+0.7187 0.4911 l
+0.7193 0.4912 l
+0.7200 0.4912 l
+0.7207 0.4913 l
+0.7213 0.4913 l
+0.7220 0.4914 l
+0.7227 0.4914 l
+0.7233 0.4915 l
+0.7240 0.4915 l
+0.7247 0.4915 l
+0.7253 0.4916 l
+0.7260 0.4916 l
+0.7267 0.4917 l
+0.7273 0.4917 l
+0.7280 0.4918 l
+0.7287 0.4918 l
+0.7293 0.4918 l
+0.7300 0.4919 l
+0.7307 0.4919 l
+0.7313 0.4920 l
+0.7320 0.4920 l
+0.7327 0.4920 l
+0.7333 0.4921 l
+0.7340 0.4921 l
+0.7347 0.4922 l
+0.7353 0.4922 l
+0.7360 0.4922 l
+0.7367 0.4923 l
+0.7373 0.4923 l
+0.7380 0.4924 l
+0.7387 0.4924 l
+0.7393 0.4924 l
+0.7400 0.4925 l
+0.7407 0.4925 l
+0.7413 0.4926 l
+0.7420 0.4926 l
+0.7427 0.4926 l
+0.7433 0.4927 l
+0.7440 0.4927 l
+0.7447 0.4927 l
+0.7453 0.4928 l
+0.7460 0.4928 l
+0.7467 0.4929 l
+0.7473 0.4929 l
+0.7480 0.4929 l
+0.7487 0.4930 l
+0.7493 0.4930 l
+0.7500 0.4930 l
+0.7507 0.4931 l
+0.7513 0.4931 l
+0.7520 0.4931 l
+0.7527 0.4932 l
+0.7533 0.4932 l
+0.7540 0.4933 l
+0.7547 0.4933 l
+0.7553 0.4933 l
+0.7560 0.4934 l
+0.7567 0.4934 l
+0.7573 0.4934 l
+0.7580 0.4935 l
+0.7587 0.4935 l
+0.7593 0.4935 l
+0.7600 0.4936 l
+0.7607 0.4936 l
+0.7613 0.4936 l
+0.7620 0.4937 l
+0.7627 0.4937 l
+0.7633 0.4937 l
+0.7640 0.4938 l
+0.7647 0.4938 l
+0.7653 0.4938 l
+0.7660 0.4938 l
+0.7667 0.4939 l
+0.7673 0.4939 l
+0.7680 0.4939 l
+0.7687 0.4940 l
+0.7693 0.4940 l
+0.7700 0.4940 l
+0.7707 0.4941 l
+0.7713 0.4941 l
+0.7720 0.4941 l
+0.7727 0.4942 l
+0.7733 0.4942 l
+0.7740 0.4942 l
+0.7747 0.4942 l
+0.7753 0.4943 l
+0.7760 0.4943 l
+0.7767 0.4943 l
+0.7773 0.4944 l
+0.7780 0.4944 l
+0.7787 0.4944 l
+0.7793 0.4944 l
+0.7800 0.4945 l
+0.7807 0.4945 l
+0.7813 0.4945 l
+0.7820 0.4945 l
+0.7827 0.4946 l
+0.7833 0.4946 l
+0.7840 0.4946 l
+0.7847 0.4947 l
+0.7853 0.4947 l
+0.7860 0.4947 l
+0.7867 0.4947 l
+0.7873 0.4948 l
+0.7880 0.4948 l
+0.7887 0.4948 l
+0.7893 0.4948 l
+0.7900 0.4949 l
+0.7907 0.4949 l
+0.7913 0.4949 l
+0.7920 0.4949 l
+0.7927 0.4950 l
+0.7933 0.4950 l
+0.7940 0.4950 l
+0.7947 0.4950 l
+0.7953 0.4951 l
+0.7960 0.4951 l
+0.7967 0.4951 l
+0.7973 0.4951 l
+0.7980 0.4951 l
+0.7987 0.4952 l
+0.7993 0.4952 l
+0.8000 0.4952 l
+0.8007 0.4952 l
+0.8013 0.4953 l
+0.8020 0.4953 l
+0.8027 0.4953 l
+0.8033 0.4953 l
+0.8040 0.4953 l
+0.8047 0.4954 l
+0.8053 0.4954 l
+0.8060 0.4954 l
+0.8067 0.4954 l
+0.8073 0.4955 l
+0.8080 0.4955 l
+0.8087 0.4955 l
+0.8093 0.4955 l
+0.8100 0.4955 l
+0.8107 0.4956 l
+0.8113 0.4956 l
+0.8120 0.4956 l
+0.8127 0.4956 l
+0.8133 0.4956 l
+0.8140 0.4956 l
+0.8147 0.4957 l
+0.8153 0.4957 l
+0.8160 0.4957 l
+s
+[/DeviceRGB] SCS
+Color1 SC
+n
+0.1500 0.4974 m
+0.1567 0.4974 l
+0.1633 0.4974 l
+0.1700 0.4974 l
+0.1767 0.4974 l
+0.1833 0.4974 l
+0.1900 0.4974 l
+0.1967 0.4974 l
+0.2033 0.4974 l
+0.2100 0.4974 l
+0.2167 0.4974 l
+0.2233 0.4974 l
+0.2300 0.4974 l
+0.2367 0.4974 l
+0.2433 0.4974 l
+0.2500 0.4974 l
+0.2567 0.4974 l
+0.2633 0.4974 l
+0.2700 0.4974 l
+0.2767 0.4974 l
+0.2833 0.4974 l
+0.2900 0.4974 l
+0.2967 0.4974 l
+0.3033 0.4974 l
+0.3100 0.4974 l
+0.3167 0.4974 l
+0.3233 0.4974 l
+0.3300 0.4974 l
+0.3367 0.4974 l
+0.3433 0.4974 l
+0.3500 0.4974 l
+0.3567 0.4974 l
+0.3633 0.4974 l
+0.3700 0.4974 l
+0.3767 0.4974 l
+0.3833 0.4974 l
+0.3900 0.4974 l
+0.3967 0.4974 l
+0.4033 0.4974 l
+0.4100 0.4974 l
+0.4167 0.4974 l
+0.4233 0.4974 l
+0.4300 0.4974 l
+0.4367 0.4974 l
+0.4433 0.4974 l
+0.4500 0.4974 l
+0.4567 0.4974 l
+0.4633 0.4974 l
+0.4700 0.4974 l
+0.4767 0.4974 l
+0.4833 0.4974 l
+0.4900 0.4974 l
+0.4967 0.4974 l
+0.5033 0.4974 l
+0.5100 0.4974 l
+0.5167 0.4974 l
+0.5233 0.4974 l
+0.5300 0.4974 l
+0.5367 0.4974 l
+0.5433 0.4974 l
+0.5500 0.4974 l
+0.5567 0.4974 l
+0.5633 0.4974 l
+0.5700 0.4974 l
+0.5767 0.4974 l
+0.5833 0.4974 l
+0.5900 0.4974 l
+0.5967 0.4974 l
+0.6033 0.4974 l
+0.6100 0.4974 l
+0.6167 0.4974 l
+0.6233 0.4974 l
+0.6300 0.4974 l
+0.6367 0.4974 l
+0.6433 0.4974 l
+0.6500 0.4974 l
+0.6567 0.4974 l
+0.6633 0.4974 l
+0.6700 0.4974 l
+0.6767 0.4974 l
+0.6833 0.4974 l
+0.6900 0.4974 l
+0.6967 0.4974 l
+0.7033 0.4974 l
+0.7100 0.4974 l
+0.7167 0.4974 l
+0.7233 0.4974 l
+0.7300 0.4974 l
+0.7367 0.4974 l
+0.7433 0.4974 l
+0.7500 0.4974 l
+0.7567 0.4974 l
+0.7633 0.4974 l
+0.7700 0.4974 l
+0.7767 0.4974 l
+0.7833 0.4974 l
+0.7900 0.4974 l
+0.7967 0.4974 l
+0.8033 0.4974 l
+0.8100 0.4974 l
+0.8167 0.4974 l
+0.8233 0.4974 l
+0.8300 0.4974 l
+0.8367 0.4974 l
+0.8433 0.4974 l
+0.8500 0.4974 l
+0.8567 0.4974 l
+0.8633 0.4974 l
+0.8700 0.4974 l
+0.8767 0.4974 l
+0.8833 0.4974 l
+0.8900 0.4974 l
+0.8967 0.4974 l
+0.9033 0.4974 l
+0.9100 0.4974 l
+0.9167 0.4974 l
+0.9233 0.4974 l
+0.9300 0.4974 l
+0.9367 0.4974 l
+0.9433 0.4974 l
+0.9500 0.4974 l
+0.9567 0.4974 l
+0.9633 0.4974 l
+0.9700 0.4974 l
+0.9767 0.4974 l
+0.9833 0.4974 l
+0.9900 0.4974 l
+0.9967 0.4974 l
+1.0033 0.4974 l
+1.0100 0.4974 l
+1.0167 0.4974 l
+1.0233 0.4974 l
+1.0300 0.4974 l
+1.0367 0.4974 l
+1.0433 0.4974 l
+1.0500 0.4974 l
+1.0567 0.4974 l
+1.0633 0.4974 l
+1.0700 0.4974 l
+1.0767 0.4974 l
+1.0833 0.4974 l
+1.0900 0.4974 l
+1.0967 0.4974 l
+1.1033 0.4974 l
+1.1100 0.4974 l
+1.1167 0.4974 l
+1.1233 0.4974 l
+1.1300 0.4974 l
+1.1367 0.4974 l
+1.1433 0.4974 l
+1.1500 0.4974 l
+1.1501 0.4974 l
+s
+[/DeviceRGB] SCS
+Color2 SC
+n 0.1500 0.1925 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.2031 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.2139 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.2235 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.2308 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.2383 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.2463 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.2500 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.2540 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.2580 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.2623 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.2666 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.2704 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.2752 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.2803 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.2851 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.2902 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.2956 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.3013 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.3072 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.3134 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.3198 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.3265 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.3334 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.3405 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.3476 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.3548 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.3618 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.3687 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.3753 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.3817 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.3879 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.3938 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.3993 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.4045 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.4094 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.4141 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.4186 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.4228 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.4269 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.4308 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.4345 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.4381 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.4415 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.4447 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.4477 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.4505 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.4530 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.4554 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.4577 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.4598 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.4617 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.4635 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.4652 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.4668 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.4683 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.4695 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.4706 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.4717 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.4727 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.4737 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.4746 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.4755 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.4764 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.4772 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.4780 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.4789 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.4797 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.4805 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.4812 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.4820 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.4827 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.4834 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.4841 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.4848 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.4855 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.4861 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.4867 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.4873 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.4879 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.4885 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.4890 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.4895 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.4900 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.4905 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.4910 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.4914 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.4918 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.4922 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.4926 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.4930 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.4934 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.4937 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.4940 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.4943 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.4946 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.4948 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.4951 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.4953 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.4955 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4957 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4959 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4960 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4962 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4963 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4965 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4966 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4967 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4968 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4968 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4969 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4970 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4970 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.1500 0.8138 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.8063 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.7983 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.7896 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.7806 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.7709 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.7611 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.7505 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.7456 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.7419 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.7388 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.7366 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.7344 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.7318 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.7287 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.7249 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.7206 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.7152 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.7092 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.7021 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.6943 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.6855 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.6760 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.6663 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.6566 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.6470 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.6380 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.6293 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.6211 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.6135 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.6062 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.5993 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.5929 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.5870 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.5816 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.5766 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.5719 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.5678 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.5640 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.5606 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.5574 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.5544 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.5516 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.5489 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.5463 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.5439 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.5416 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.5394 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.5373 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.5354 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.5335 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.5317 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.5300 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.5284 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.5270 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.5258 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.5246 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.5235 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.5224 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.5214 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.5204 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.5194 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.5184 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.5175 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.5166 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.5157 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.5149 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.5142 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.5135 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.5128 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.5121 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.5114 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.5107 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.5101 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.5094 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.5088 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.5082 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.5076 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.5070 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.5064 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.5058 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.5053 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.5048 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.5043 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.5038 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.5033 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.5029 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.5025 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.5021 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.5017 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.5013 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.5010 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.5007 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.5004 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.5002 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.4999 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.4997 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.4995 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.4993 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.4991 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4990 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4988 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4987 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4986 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4984 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4983 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4982 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4981 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4981 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4980 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4979 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+[/DeviceRGB] SCS
+Color4 SC
+n 0.1500 0.1925 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.2028 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.2124 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.2213 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.2297 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.2378 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.2457 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.2507 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.2545 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.2583 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.2622 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.2659 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.2678 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.2703 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.2734 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.2769 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.2810 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.2855 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.2905 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.2958 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.3004 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.3052 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.3103 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.3156 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.3211 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.3266 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.3323 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.3380 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.3436 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.3492 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.3548 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.3603 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.3658 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.3711 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.3764 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.3815 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.3866 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.3915 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.3963 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.4010 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.4055 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.4100 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.4143 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.4185 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.4225 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.4264 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.4301 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.4337 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.4370 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.4403 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.4434 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.4463 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.4492 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.4520 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.4547 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.4573 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.4598 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.4623 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.4646 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.4668 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.4689 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.4709 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.4727 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.4744 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.4760 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.4776 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.4789 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.4802 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.4814 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.4825 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.4835 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.4844 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.4852 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.4860 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.4868 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.4874 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.4881 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.4887 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.4892 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.4897 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.4902 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.4907 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.4911 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.4915 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.4919 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.4922 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.4926 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.4929 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.4932 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.4935 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.4938 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.4940 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.4943 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.4945 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.4947 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.4949 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.4951 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.4953 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.4955 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.4957 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4958 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4960 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4961 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4962 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4963 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4964 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4965 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4966 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4967 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4968 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4969 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4969 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4970 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4970 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.1500 0.8138 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.8063 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.7982 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.7889 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.7785 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.7677 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.7564 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.7488 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.7451 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.7417 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.7379 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.7338 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.7309 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.7281 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.7250 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.7216 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.7179 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.7138 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.7095 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.7049 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.6999 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.6947 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.6892 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.6833 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.6772 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.6709 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.6645 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.6581 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.6517 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.6454 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.6391 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.6328 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.6267 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.6208 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.6149 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.6093 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.6037 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.5984 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.5932 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.5882 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.5833 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.5787 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.5742 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.5699 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.5657 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.5618 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.5581 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.5546 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.5513 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.5481 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.5452 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.5423 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.5396 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.5370 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.5345 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.5321 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.5298 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.5277 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.5256 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.5237 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.5219 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.5202 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.5186 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.5171 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.5158 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.5146 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.5134 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.5124 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.5114 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.5106 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.5098 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.5090 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.5084 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.5077 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.5072 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.5066 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.5061 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.5056 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.5052 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.5047 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.5043 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.5039 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.5035 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.5032 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.5028 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.5025 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.5022 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.5019 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.5016 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.5013 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.5010 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.5008 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.5005 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.5003 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.5001 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.4999 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.4997 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.4995 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.4993 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.4992 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4990 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4989 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4987 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4986 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4985 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4984 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4983 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4982 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4981 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4980 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4980 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4979 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4975 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+[/DeviceRGB] SCS
+Color3 SC
+n 0.1500 0.1925 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.2048 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.2034 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.2006 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.1988 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.1977 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.1974 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.1976 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.1987 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.2001 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.2023 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.2050 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.2086 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.2127 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.2176 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.2226 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.2272 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.2320 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.2372 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.2427 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.2484 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.2543 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.2604 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.2670 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.2740 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.2812 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.2888 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.2967 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.3047 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.3128 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.3210 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.3291 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.3373 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.3452 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.3530 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.3607 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.3682 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.3754 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.3823 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.3888 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.3948 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.4007 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.4061 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.4111 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.4159 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.4204 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.4246 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.4285 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.4323 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.4359 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.4392 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.4425 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.4456 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.4485 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.4514 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.4541 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.4567 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.4592 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.4616 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.4639 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.4660 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.4680 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.4699 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.4716 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.4732 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.4747 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.4761 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.4774 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.4785 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.4795 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.4805 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.4814 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.4822 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.4829 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.4836 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.4842 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.4847 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.4852 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.4857 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.4862 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.4867 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.4872 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.4877 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.4882 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.4887 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.4891 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.4896 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.4901 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.4906 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.4910 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.4914 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.4919 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.4923 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.4926 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.4930 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.4934 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.4937 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.4940 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.4943 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.4946 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4948 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4951 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4953 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4955 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4957 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4959 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4961 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4962 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4963 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4965 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4966 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4967 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4968 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4969 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4969 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4970 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4971 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4972 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4973 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+n 0.1500 0.8138 0.0024 0.0024 0 360 EARC s
+n 0.1567 0.8059 0.0024 0.0024 0 360 EARC s
+n 0.1633 0.7996 0.0024 0.0024 0 360 EARC s
+n 0.1700 0.8039 0.0024 0.0024 0 360 EARC s
+n 0.1767 0.8067 0.0024 0.0024 0 360 EARC s
+n 0.1833 0.8075 0.0024 0.0024 0 360 EARC s
+n 0.1900 0.8069 0.0024 0.0024 0 360 EARC s
+n 0.1967 0.8050 0.0024 0.0024 0 360 EARC s
+n 0.2033 0.8039 0.0024 0.0024 0 360 EARC s
+n 0.2100 0.8032 0.0024 0.0024 0 360 EARC s
+n 0.2167 0.8013 0.0024 0.0024 0 360 EARC s
+n 0.2233 0.7982 0.0024 0.0024 0 360 EARC s
+n 0.2300 0.7941 0.0024 0.0024 0 360 EARC s
+n 0.2367 0.7892 0.0024 0.0024 0 360 EARC s
+n 0.2433 0.7836 0.0024 0.0024 0 360 EARC s
+n 0.2500 0.7772 0.0024 0.0024 0 360 EARC s
+n 0.2567 0.7701 0.0024 0.0024 0 360 EARC s
+n 0.2633 0.7646 0.0024 0.0024 0 360 EARC s
+n 0.2700 0.7593 0.0024 0.0024 0 360 EARC s
+n 0.2767 0.7538 0.0024 0.0024 0 360 EARC s
+n 0.2833 0.7480 0.0024 0.0024 0 360 EARC s
+n 0.2900 0.7418 0.0024 0.0024 0 360 EARC s
+n 0.2967 0.7353 0.0024 0.0024 0 360 EARC s
+n 0.3033 0.7284 0.0024 0.0024 0 360 EARC s
+n 0.3100 0.7212 0.0024 0.0024 0 360 EARC s
+n 0.3167 0.7138 0.0024 0.0024 0 360 EARC s
+n 0.3233 0.7063 0.0024 0.0024 0 360 EARC s
+n 0.3300 0.6988 0.0024 0.0024 0 360 EARC s
+n 0.3367 0.6918 0.0024 0.0024 0 360 EARC s
+n 0.3433 0.6861 0.0024 0.0024 0 360 EARC s
+n 0.3500 0.6804 0.0024 0.0024 0 360 EARC s
+n 0.3567 0.6745 0.0024 0.0024 0 360 EARC s
+n 0.3633 0.6686 0.0024 0.0024 0 360 EARC s
+n 0.3700 0.6626 0.0024 0.0024 0 360 EARC s
+n 0.3767 0.6566 0.0024 0.0024 0 360 EARC s
+n 0.3833 0.6505 0.0024 0.0024 0 360 EARC s
+n 0.3900 0.6445 0.0024 0.0024 0 360 EARC s
+n 0.3967 0.6385 0.0024 0.0024 0 360 EARC s
+n 0.4033 0.6326 0.0024 0.0024 0 360 EARC s
+n 0.4100 0.6266 0.0024 0.0024 0 360 EARC s
+n 0.4167 0.6208 0.0024 0.0024 0 360 EARC s
+n 0.4233 0.6150 0.0024 0.0024 0 360 EARC s
+n 0.4300 0.6094 0.0024 0.0024 0 360 EARC s
+n 0.4367 0.6039 0.0024 0.0024 0 360 EARC s
+n 0.4433 0.5986 0.0024 0.0024 0 360 EARC s
+n 0.4500 0.5934 0.0024 0.0024 0 360 EARC s
+n 0.4567 0.5886 0.0024 0.0024 0 360 EARC s
+n 0.4633 0.5839 0.0024 0.0024 0 360 EARC s
+n 0.4700 0.5796 0.0024 0.0024 0 360 EARC s
+n 0.4767 0.5755 0.0024 0.0024 0 360 EARC s
+n 0.4833 0.5716 0.0024 0.0024 0 360 EARC s
+n 0.4900 0.5679 0.0024 0.0024 0 360 EARC s
+n 0.4967 0.5643 0.0024 0.0024 0 360 EARC s
+n 0.5033 0.5610 0.0024 0.0024 0 360 EARC s
+n 0.5100 0.5578 0.0024 0.0024 0 360 EARC s
+n 0.5167 0.5547 0.0024 0.0024 0 360 EARC s
+n 0.5233 0.5517 0.0024 0.0024 0 360 EARC s
+n 0.5300 0.5488 0.0024 0.0024 0 360 EARC s
+n 0.5367 0.5461 0.0024 0.0024 0 360 EARC s
+n 0.5433 0.5434 0.0024 0.0024 0 360 EARC s
+n 0.5500 0.5409 0.0024 0.0024 0 360 EARC s
+n 0.5567 0.5386 0.0024 0.0024 0 360 EARC s
+n 0.5633 0.5363 0.0024 0.0024 0 360 EARC s
+n 0.5700 0.5342 0.0024 0.0024 0 360 EARC s
+n 0.5767 0.5322 0.0024 0.0024 0 360 EARC s
+n 0.5833 0.5303 0.0024 0.0024 0 360 EARC s
+n 0.5900 0.5285 0.0024 0.0024 0 360 EARC s
+n 0.5967 0.5267 0.0024 0.0024 0 360 EARC s
+n 0.6033 0.5251 0.0024 0.0024 0 360 EARC s
+n 0.6100 0.5235 0.0024 0.0024 0 360 EARC s
+n 0.6167 0.5220 0.0024 0.0024 0 360 EARC s
+n 0.6233 0.5206 0.0024 0.0024 0 360 EARC s
+n 0.6300 0.5193 0.0024 0.0024 0 360 EARC s
+n 0.6367 0.5180 0.0024 0.0024 0 360 EARC s
+n 0.6433 0.5168 0.0024 0.0024 0 360 EARC s
+n 0.6500 0.5156 0.0024 0.0024 0 360 EARC s
+n 0.6567 0.5145 0.0024 0.0024 0 360 EARC s
+n 0.6633 0.5134 0.0024 0.0024 0 360 EARC s
+n 0.6700 0.5124 0.0024 0.0024 0 360 EARC s
+n 0.6767 0.5115 0.0024 0.0024 0 360 EARC s
+n 0.6833 0.5105 0.0024 0.0024 0 360 EARC s
+n 0.6900 0.5097 0.0024 0.0024 0 360 EARC s
+n 0.6967 0.5089 0.0024 0.0024 0 360 EARC s
+n 0.7033 0.5081 0.0024 0.0024 0 360 EARC s
+n 0.7100 0.5073 0.0024 0.0024 0 360 EARC s
+n 0.7167 0.5066 0.0024 0.0024 0 360 EARC s
+n 0.7233 0.5060 0.0024 0.0024 0 360 EARC s
+n 0.7300 0.5053 0.0024 0.0024 0 360 EARC s
+n 0.7367 0.5047 0.0024 0.0024 0 360 EARC s
+n 0.7433 0.5042 0.0024 0.0024 0 360 EARC s
+n 0.7500 0.5036 0.0024 0.0024 0 360 EARC s
+n 0.7567 0.5031 0.0024 0.0024 0 360 EARC s
+n 0.7633 0.5027 0.0024 0.0024 0 360 EARC s
+n 0.7700 0.5022 0.0024 0.0024 0 360 EARC s
+n 0.7767 0.5018 0.0024 0.0024 0 360 EARC s
+n 0.7833 0.5015 0.0024 0.0024 0 360 EARC s
+n 0.7900 0.5011 0.0024 0.0024 0 360 EARC s
+n 0.7967 0.5008 0.0024 0.0024 0 360 EARC s
+n 0.8033 0.5005 0.0024 0.0024 0 360 EARC s
+n 0.8100 0.5002 0.0024 0.0024 0 360 EARC s
+n 0.8167 0.4999 0.0024 0.0024 0 360 EARC s
+n 0.8233 0.4997 0.0024 0.0024 0 360 EARC s
+n 0.8300 0.4995 0.0024 0.0024 0 360 EARC s
+n 0.8367 0.4992 0.0024 0.0024 0 360 EARC s
+n 0.8433 0.4991 0.0024 0.0024 0 360 EARC s
+n 0.8500 0.4989 0.0024 0.0024 0 360 EARC s
+n 0.8567 0.4987 0.0024 0.0024 0 360 EARC s
+n 0.8633 0.4986 0.0024 0.0024 0 360 EARC s
+n 0.8700 0.4984 0.0024 0.0024 0 360 EARC s
+n 0.8767 0.4983 0.0024 0.0024 0 360 EARC s
+n 0.8833 0.4982 0.0024 0.0024 0 360 EARC s
+n 0.8900 0.4981 0.0024 0.0024 0 360 EARC s
+n 0.8967 0.4980 0.0024 0.0024 0 360 EARC s
+n 0.9033 0.4979 0.0024 0.0024 0 360 EARC s
+n 0.9100 0.4979 0.0024 0.0024 0 360 EARC s
+n 0.9167 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.9233 0.4978 0.0024 0.0024 0 360 EARC s
+n 0.9300 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9367 0.4977 0.0024 0.0024 0 360 EARC s
+n 0.9433 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9500 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9567 0.4976 0.0024 0.0024 0 360 EARC s
+n 0.9633 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9700 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9767 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9833 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9900 0.4975 0.0024 0.0024 0 360 EARC s
+n 0.9967 0.4975 0.0024 0.0024 0 360 EARC s
+n 1.0033 0.4975 0.0024 0.0024 0 360 EARC s
+n 1.0100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0500 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0567 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0633 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0700 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0767 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0833 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0900 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.0967 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1033 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1100 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1167 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1233 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1300 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1367 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1433 0.4974 0.0024 0.0024 0 360 EARC s
+n 1.1500 0.4974 0.0024 0.0024 0 360 EARC s
+[/DeviceRGB] SCS
+Color1 SC
+n
+0.1500 0.1500 m
+1.1500 0.1500 l
+s
+n
+0.1500 0.8500 m
+1.1500 0.8500 l
+s
+n
+0.3167 0.1500 m
+0.3167 0.1600 l
+s
+n
+0.3167 0.8500 m
+0.3167 0.8400 l
+s
+n
+0.6500 0.1500 m
+0.6500 0.1600 l
+s
+n
+0.6500 0.8500 m
+0.6500 0.8400 l
+s
+n
+0.9833 0.1500 m
+0.9833 0.1600 l
+s
+n
+0.9833 0.8500 m
+0.9833 0.8400 l
+s
+n
+0.1500 0.1500 m
+0.1500 0.1700 l
+s
+n
+0.1500 0.8500 m
+0.1500 0.8300 l
+s
+n
+0.4833 0.1500 m
+0.4833 0.1700 l
+s
+n
+0.4833 0.8500 m
+0.4833 0.8300 l
+s
+n
+0.8167 0.1500 m
+0.8167 0.1700 l
+s
+n
+0.8167 0.8500 m
+0.8167 0.8300 l
+s
+n
+1.1500 0.1500 m
+1.1500 0.1700 l
+s
+n
+1.1500 0.8500 m
+1.1500 0.8300 l
+s
+/Times-Roman findfont
+dup length dict begin
+ {1 index /FID ne {def} {pop pop} ifelse} forall
+ /Encoding DefEncoding def
+ currentdict
+end
+/Font0 exch definefont pop
+/Font0 FFSF
+0.1433 0.1210 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(0) show
+GR
+/Font0 FFSF
+0.4628 0.1206 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(500) show
+GR
+/Font0 FFSF
+0.7890 0.1210 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(1000) show
+GR
+/Font0 FFSF
+1.1224 0.1206 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(1500) show
+GR
+/Font0 FFSF
+0.5978 0.0909 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(Iterations) show
+GR
+n
+0.1500 0.1500 m
+0.1500 0.8500 l
+s
+n
+1.1500 0.1500 m
+1.1500 0.8500 l
+s
+n
+0.1500 0.1500 m
+0.1600 0.1500 l
+s
+n
+1.1500 0.1500 m
+1.1400 0.1500 l
+s
+n
+0.1500 0.3833 m
+0.1600 0.3833 l
+s
+n
+1.1500 0.3833 m
+1.1400 0.3833 l
+s
+n
+0.1500 0.6167 m
+0.1600 0.6167 l
+s
+n
+1.1500 0.6167 m
+1.1400 0.6167 l
+s
+n
+0.1500 0.8500 m
+0.1600 0.8500 l
+s
+n
+1.1500 0.8500 m
+1.1400 0.8500 l
+s
+n
+0.1500 0.2667 m
+0.1700 0.2667 l
+s
+n
+1.1500 0.2667 m
+1.1300 0.2667 l
+s
+n
+0.1500 0.5000 m
+0.1700 0.5000 l
+s
+n
+1.1500 0.5000 m
+1.1300 0.5000 l
+s
+n
+0.1500 0.7333 m
+0.1700 0.7333 l
+s
+n
+1.1500 0.7333 m
+1.1300 0.7333 l
+s
+/Font0 FFSF
+0.1267 0.2574 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(0) show
+GR
+/Font0 FFSF
+0.1069 0.4923 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(0,5) show
+GR
+/Font0 FFSF
+0.1291 0.7239 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(1) show
+GR
+/Font0 FFSF
+0.0909 0.3626 m
+GS
+[0.0000 0.0280 -0.0280 0.0000 0 0] CC
+(Scalaire \(min, avg, max\)) show
+GR
+n
+0.1500 0.1500 m
+0.1500 0.8500 l
+1.1500 0.8500 l
+1.1500 0.1500 l
+0.1500 0.1500 l
+c
+s
+n
+0.8500 0.8000 m
+0.8500 0.6604 l
+1.1494 0.6604 l
+1.1494 0.8000 l
+c
+[/DeviceRGB] SCS
+Color0 SC
+fill
+[/DeviceRGB] SCS
+Color1 SC
+n
+0.8500 0.8000 m
+0.8500 0.6604 l
+1.1494 0.6604 l
+1.1494 0.8000 l
+0.8500 0.8000 l
+c
+s
+/Font0 FFSF
+0.9208 0.7706 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(isotrope \(reference\)) show
+GR
+[/DeviceRGB] SCS
+Color2 SC
+n
+0.8608 0.7773 m
+0.9008 0.7773 l
+s
+/Font0 FFSF
+[/DeviceRGB] SCS
+Color1 SC
+0.9208 0.7352 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(isotrope) show
+GR
+[/DeviceRGB] SCS
+Color2 SC
+n 0.8808 0.7419 0.0024 0.0024 0 360 EARC s
+/Font0 FFSF
+[/DeviceRGB] SCS
+Color1 SC
+0.9208 0.7063 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(none) show
+GR
+[/DeviceRGB] SCS
+Color4 SC
+n 0.8808 0.7125 0.0024 0.0024 0 360 EARC s
+/Font0 FFSF
+[/DeviceRGB] SCS
+Color1 SC
+0.9208 0.6765 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(anisotrope) show
+GR
+[/DeviceRGB] SCS
+Color3 SC
+n 0.8808 0.6832 0.0024 0.0024 0 360 EARC s
+/Font0 FFSF
+[/DeviceRGB] SCS
+Color1 SC
+0.2115 0.9193 m
+GS
+[0.0420 0.0000 0.0000 0.0420 0 0] CC
+(Evolution du scalaire pour 3 methodes de dealiasing) show
+GR
+/Font0 FFSF
+0.4947 0.8740 m
+GS
+[0.0280 0.0000 0.0000 0.0280 0 0] CC
+(Schmidt=0.1, 128x128x128) show
+GR
+%%Trailer
+%%BoundingBox: 41 52 702 565
+%%DocumentNeededResources: font Times-Roman
+%%EOF
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.png b/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.png
new file mode 100644
index 0000000000000000000000000000000000000000..ccc247514effb77ac0c9d2cd0e7bb543c0c0c81f
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/doxygen/images/dealias.png differ
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.eps b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.eps
new file mode 100644
index 0000000000000000000000000000000000000000..39b0e196f28fd8d73fb86ac5eafd8bdc83ef2da2
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.eps
@@ -0,0 +1,209 @@
+%!PS-Adobe-2.0 EPSF-2.0
+%%Title: parallel.fig
+%%Creator: fig2dev Version 3.2 Patchlevel 5
+%%CreationDate: Tue Jul 19 12:08:34 2011
+%%For: begou@thor (Patrick Begou)
+%%BoundingBox: 0 0 396 407
+%Magnification: 1.0000
+%%EndComments
+%%BeginProlog
+/$F2psDict 200 dict def
+$F2psDict begin
+$F2psDict /mtrx matrix put
+/col-1 {0 setgray} bind def
+/col0 {0.000 0.000 0.000 srgb} bind def
+/col1 {0.000 0.000 1.000 srgb} bind def
+/col2 {0.000 1.000 0.000 srgb} bind def
+/col3 {0.000 1.000 1.000 srgb} bind def
+/col4 {1.000 0.000 0.000 srgb} bind def
+/col5 {1.000 0.000 1.000 srgb} bind def
+/col6 {1.000 1.000 0.000 srgb} bind def
+/col7 {1.000 1.000 1.000 srgb} bind def
+/col8 {0.000 0.000 0.560 srgb} bind def
+/col9 {0.000 0.000 0.690 srgb} bind def
+/col10 {0.000 0.000 0.820 srgb} bind def
+/col11 {0.530 0.810 1.000 srgb} bind def
+/col12 {0.000 0.560 0.000 srgb} bind def
+/col13 {0.000 0.690 0.000 srgb} bind def
+/col14 {0.000 0.820 0.000 srgb} bind def
+/col15 {0.000 0.560 0.560 srgb} bind def
+/col16 {0.000 0.690 0.690 srgb} bind def
+/col17 {0.000 0.820 0.820 srgb} bind def
+/col18 {0.560 0.000 0.000 srgb} bind def
+/col19 {0.690 0.000 0.000 srgb} bind def
+/col20 {0.820 0.000 0.000 srgb} bind def
+/col21 {0.560 0.000 0.560 srgb} bind def
+/col22 {0.690 0.000 0.690 srgb} bind def
+/col23 {0.820 0.000 0.820 srgb} bind def
+/col24 {0.500 0.190 0.000 srgb} bind def
+/col25 {0.630 0.250 0.000 srgb} bind def
+/col26 {0.750 0.380 0.000 srgb} bind def
+/col27 {1.000 0.500 0.500 srgb} bind def
+/col28 {1.000 0.630 0.630 srgb} bind def
+/col29 {1.000 0.750 0.750 srgb} bind def
+/col30 {1.000 0.880 0.880 srgb} bind def
+/col31 {1.000 0.840 0.000 srgb} bind def
+
+end
+save
+newpath 0 407 moveto 0 0 lineto 396 0 lineto 396 407 lineto closepath clip newpath
+-211.8 496.8 translate
+1 -1 scale
+
+/cp {closepath} bind def
+/ef {eofill} bind def
+/gr {grestore} bind def
+/gs {gsave} bind def
+/sa {save} bind def
+/rs {restore} bind def
+/l {lineto} bind def
+/m {moveto} bind def
+/rm {rmoveto} bind def
+/n {newpath} bind def
+/s {stroke} bind def
+/sh {show} bind def
+/slc {setlinecap} bind def
+/slj {setlinejoin} bind def
+/slw {setlinewidth} bind def
+/srgb {setrgbcolor} bind def
+/rot {rotate} bind def
+/sc {scale} bind def
+/sd {setdash} bind def
+/ff {findfont} bind def
+/sf {setfont} bind def
+/scf {scalefont} bind def
+/sw {stringwidth} bind def
+/tr {translate} bind def
+/tnt {dup dup currentrgbcolor
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb}
+ bind def
+/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul
+ 4 -2 roll mul srgb} bind def
+/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def
+/$F2psEnd {$F2psEnteredState restore end} def
+
+$F2psBegin
+10 setmiterlimit
+0 slj 0 slc
+ 0.06299 0.06299 sc
+%%EndProlog
+%
+% Fig objects follow
+%
+%
+% here starts figure with depth 50
+% Polyline
+0 slj
+0 slc
+30.000 slw
+gs clippath
+5143 6351 m 4873 6232 l 4819 6355 l 5088 6474 l 5088 6474 l 4910 6322 l 5143 6351 l cp
+eoclip
+n 6390 6975 m
+ 4860 6300 l gs col0 s gr gr
+
+% arrowhead
+n 5143 6351 m 4910 6322 l 5088 6474 l 5074 6394 l 5143 6351 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+gs clippath
+7868 6425 m 8140 6311 l 8087 6186 l 7816 6301 l 7816 6301 l 8050 6276 l 7868 6425 l cp
+eoclip
+n 6390 6975 m
+ 8100 6255 l gs col0 s gr gr
+
+% arrowhead
+n 7868 6425 m 8050 6276 l 7816 6301 l 7884 6345 l 7868 6425 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+ [120] 0 sd
+gs clippath
+4484 4682 m 4346 4878 l 4456 4956 l 4594 4760 l 4594 4760 l 4436 4869 l 4484 4682 l cp
+eoclip
+n 5895 2790 m
+ 4410 4905 l gs col0 s gr gr
+ [] 0 sd
+% arrowhead
+n 4484 4682 m 4436 4869 l 4594 4760 l 4484 4682 l cp gs col7 1.00 shd ef gr col0 s
+% Polyline
+ [120] 0 sd
+gs clippath
+7501 4817 m 7652 5004 l 7756 4919 l 7605 4732 l 7605 4732 l 7667 4915 l 7501 4817 l cp
+eoclip
+n 5940 2790 m
+ 7695 4950 l gs col0 s gr gr
+ [] 0 sd
+% arrowhead
+n 7501 4817 m 7667 4915 l 7605 4732 l 7501 4817 l cp gs col7 1.00 shd ef gr col0 s
+% Polyline
+7.500 slw
+n 3480 4905 m 3375 4905 3375 6195 105 arcto 4 {pop} repeat
+ 3375 6300 6195 6300 105 arcto 4 {pop} repeat
+ 6300 6300 6300 5010 105 arcto 4 {pop} repeat
+ 6300 4905 3480 4905 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+% Polyline
+n 6810 4950 m 6705 4950 6705 6150 105 arcto 4 {pop} repeat
+ 6705 6255 9525 6255 105 arcto 4 {pop} repeat
+ 9630 6255 9630 5055 105 arcto 4 {pop} repeat
+ 9630 4950 6810 4950 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+% Polyline
+n 4920 6975 m 4815 6975 4815 7770 105 arcto 4 {pop} repeat
+ 4815 7875 7815 7875 105 arcto 4 {pop} repeat
+ 7920 7875 7920 7080 105 arcto 4 {pop} repeat
+ 7920 6975 4920 6975 105 arcto 4 {pop} repeat
+ cp gs col0 s gr
+% Polyline
+n 4500 1440 m 7695 1440 l 7695 2790 l 4500 2790 l
+ cp gs col0 s gr
+/Times-Roman ff 190.50 scf sf
+6075 4545 m
+gs 1 -1 sc (automatic code generation) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+5850 6615 m
+gs 1 -1 sc 328.0 rot (use) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7020 6615 m
+gs 1 -1 sc 30.0 rot (use) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4680 5850 m
+gs 1 -1 sc (for real type values.) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8055 5850 m
+gs 1 -1 sc (for complex type values.) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6435 7695 m
+gs 1 -1 sc (Generic interface for parallel) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Italic ff 190.50 scf sf
+5985 2160 m
+gs 1 -1 sc (Module generic implementation) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Italic ff 190.50 scf sf
+5940 2475 m
+gs 1 -1 sc (with tags.) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-BoldItalic ff 222.25 scf sf
+6075 1710 m
+gs 1 -1 sc (implementparallel.Fortran) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Bold ff 222.25 scf sf
+4815 5175 m
+gs 1 -1 sc (module realparallel) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4725 5580 m
+gs 1 -1 sc (Parallel code and functions) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Bold ff 222.25 scf sf
+8145 5220 m
+gs 1 -1 sc (module cmplxparallel) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8145 5625 m
+gs 1 -1 sc (Parallel code and functions) dup sw pop 2 div neg 0 rm col0 sh gr
+/Times-Bold ff 222.25 scf sf
+6435 7290 m
+gs 1 -1 sc (module parallel) dup sw pop 2 div neg 0 rm col0 sh gr
+% here ends figure;
+$F2psEnd
+rs
+showpage
+%%Trailer
+%EOF
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.fig b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.fig
new file mode 100644
index 0000000000000000000000000000000000000000..998b3e50b842201ef8b9ebd2764482e432fb0423
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.fig
@@ -0,0 +1,43 @@
+#FIG 3.2 Produced by xfig version 3.2.5
+Landscape
+Center
+Metric
+A4
+100.00
+Single
+-2
+1200 2
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 6390 6975 4860 6300
+2 1 0 3 0 7 50 -1 -1 0.000 0 0 -1 1 0 2
+ 2 1 3.00 135.00 180.00
+ 6390 6975 8100 6255
+2 1 1 3 0 7 50 -1 -1 8.000 0 0 -1 1 0 2
+ 1 0 3.00 135.00 180.00
+ 5895 2790 4410 4905
+2 1 1 3 0 7 50 -1 -1 8.000 0 0 -1 1 0 2
+ 1 0 3.00 135.00 180.00
+ 5940 2790 7695 4950
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 6300 6300 6300 4905 3375 4905 3375 6300 6300 6300
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 9630 6255 9630 4950 6705 4950 6705 6255 9630 6255
+2 4 0 1 0 7 50 -1 -1 0.000 0 0 7 0 0 5
+ 7920 7875 7920 6975 4815 6975 4815 7875 7920 7875
+2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 4500 1440 7695 1440 7695 2790 4500 2790 4500 1440
+4 1 0 50 -1 0 12 0.0000 4 180 2160 6075 4545 automatic code generation\001
+4 1 0 50 -1 0 12 5.7247 4 90 270 5850 6615 use\001
+4 1 0 50 -1 0 12 0.5236 4 90 270 7020 6615 use\001
+4 1 0 50 -1 0 12 0.0000 4 180 1590 4680 5850 for real type values.\001
+4 1 0 50 -1 0 12 0.0000 4 180 1995 8055 5850 for complex type values.\001
+4 1 0 50 -1 0 12 0.0000 4 180 2310 6435 7695 Generic interface for parallel\001
+4 1 0 50 -1 1 12 0.0000 4 180 2610 5985 2160 Module generic implementation\001
+4 1 0 50 -1 1 12 0.0000 4 180 795 5940 2475 with tags.\001
+4 1 0 50 -1 3 14 0.0000 4 210 2580 6075 1710 implementparallel.Fortran\001
+4 1 0 50 -1 2 14 0.0000 4 210 1965 4815 5175 module realparallel\001
+4 1 0 50 -1 0 12 0.0000 4 135 2205 4725 5580 Parallel code and functions\001
+4 1 0 50 -1 2 14 0.0000 4 210 2190 8145 5220 module cmplxparallel\001
+4 1 0 50 -1 0 12 0.0000 4 135 2205 8145 5625 Parallel code and functions\001
+4 1 0 50 -1 2 14 0.0000 4 210 1575 6435 7290 module parallel\001
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.png b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.png
new file mode 100644
index 0000000000000000000000000000000000000000..642d7dd9e129d8928dad1bd901b0246d42674d0c
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/doxygen/images/parallel.png differ
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.eps b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.eps
new file mode 100644
index 0000000000000000000000000000000000000000..5d79e43685047e31f1f9daa4a6bae95279f56301
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.eps
@@ -0,0 +1,246 @@
+%!PS-Adobe-2.0 EPSF-2.0
+%%Title: xycommunicator.fig
+%%Creator: fig2dev Version 3.2 Patchlevel 5
+%%CreationDate: Thu Jun 30 17:38:58 2011
+%%For: begou@thor (Patrick Begou)
+%%BoundingBox: 0 0 399 148
+%Magnification: 1.0000
+%%EndComments
+%%BeginProlog
+/$F2psDict 200 dict def
+$F2psDict begin
+$F2psDict /mtrx matrix put
+/col-1 {0 setgray} bind def
+/col0 {0.000 0.000 0.000 srgb} bind def
+/col1 {0.000 0.000 1.000 srgb} bind def
+/col2 {0.000 1.000 0.000 srgb} bind def
+/col3 {0.000 1.000 1.000 srgb} bind def
+/col4 {1.000 0.000 0.000 srgb} bind def
+/col5 {1.000 0.000 1.000 srgb} bind def
+/col6 {1.000 1.000 0.000 srgb} bind def
+/col7 {1.000 1.000 1.000 srgb} bind def
+/col8 {0.000 0.000 0.560 srgb} bind def
+/col9 {0.000 0.000 0.690 srgb} bind def
+/col10 {0.000 0.000 0.820 srgb} bind def
+/col11 {0.530 0.810 1.000 srgb} bind def
+/col12 {0.000 0.560 0.000 srgb} bind def
+/col13 {0.000 0.690 0.000 srgb} bind def
+/col14 {0.000 0.820 0.000 srgb} bind def
+/col15 {0.000 0.560 0.560 srgb} bind def
+/col16 {0.000 0.690 0.690 srgb} bind def
+/col17 {0.000 0.820 0.820 srgb} bind def
+/col18 {0.560 0.000 0.000 srgb} bind def
+/col19 {0.690 0.000 0.000 srgb} bind def
+/col20 {0.820 0.000 0.000 srgb} bind def
+/col21 {0.560 0.000 0.560 srgb} bind def
+/col22 {0.690 0.000 0.690 srgb} bind def
+/col23 {0.820 0.000 0.820 srgb} bind def
+/col24 {0.500 0.190 0.000 srgb} bind def
+/col25 {0.630 0.250 0.000 srgb} bind def
+/col26 {0.750 0.380 0.000 srgb} bind def
+/col27 {1.000 0.500 0.500 srgb} bind def
+/col28 {1.000 0.630 0.630 srgb} bind def
+/col29 {1.000 0.750 0.750 srgb} bind def
+/col30 {1.000 0.880 0.880 srgb} bind def
+/col31 {1.000 0.840 0.000 srgb} bind def
+
+end
+save
+newpath 0 148 moveto 0 0 lineto 399 0 lineto 399 148 lineto closepath clip newpath
+-70.0 259.6 translate
+1 -1 scale
+
+/cp {closepath} bind def
+/ef {eofill} bind def
+/gr {grestore} bind def
+/gs {gsave} bind def
+/sa {save} bind def
+/rs {restore} bind def
+/l {lineto} bind def
+/m {moveto} bind def
+/rm {rmoveto} bind def
+/n {newpath} bind def
+/s {stroke} bind def
+/sh {show} bind def
+/slc {setlinecap} bind def
+/slj {setlinejoin} bind def
+/slw {setlinewidth} bind def
+/srgb {setrgbcolor} bind def
+/rot {rotate} bind def
+/sc {scale} bind def
+/sd {setdash} bind def
+/ff {findfont} bind def
+/sf {setfont} bind def
+/scf {scalefont} bind def
+/sw {stringwidth} bind def
+/tr {translate} bind def
+/tnt {dup dup currentrgbcolor
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb}
+ bind def
+/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul
+ 4 -2 roll mul srgb} bind def
+/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def
+/$F2psEnd {$F2psEnteredState restore end} def
+
+$F2psBegin
+10 setmiterlimit
+0 slj 0 slc
+ 0.06299 0.06299 sc
+%%EndProlog
+%
+% Fig objects follow
+%
+%
+% here starts figure with depth 51
+% Polyline
+2 slj
+0 slc
+7.500 slw
+gs clippath
+4360 3919 m 4556 3788 l 4490 3688 l 4294 3819 l 4294 3819 l 4499 3755 l 4360 3919 l cp
+eoclip
+n 3185 3362 m 3183 3364 l 3179 3368 l 3171 3374 l 3161 3385 l 3147 3398 l
+ 3131 3414 l 3113 3433 l 3095 3453 l 3077 3475 l 3060 3499 l
+ 3044 3524 l 3029 3550 l 3017 3579 l 3008 3609 l 3002 3643 l
+ 3001 3679 l 3004 3716 l 3011 3746 l 3020 3775 l 3030 3801 l
+ 3040 3824 l 3049 3843 l 3058 3859 l 3065 3872 l 3071 3883 l
+ 3077 3892 l 3082 3900 l 3087 3907 l 3092 3914 l 3099 3922 l
+ 3107 3929 l 3118 3939 l 3131 3949 l 3148 3961 l 3169 3975 l
+ 3194 3991 l 3225 4008 l 3259 4025 l 3298 4041 l 3335 4054 l
+ 3372 4064 l 3407 4073 l 3438 4080 l 3465 4085 l 3489 4089 l
+ 3508 4092 l 3523 4094 l 3536 4095 l 3547 4096 l 3556 4097 l
+ 3564 4097 l 3573 4096 l 3583 4096 l 3594 4095 l 3608 4094 l
+ 3626 4092 l 3648 4089 l 3675 4086 l 3708 4081 l 3746 4076 l
+ 3789 4068 l 3836 4059 l 3886 4048 l 3933 4036 l 3978 4022 l
+ 4021 4008 l 4063 3993 l 4102 3978 l 4138 3963 l 4173 3947 l
+ 4206 3931 l 4238 3915 l 4268 3899 l 4297 3883 l 4325 3867 l
+ 4351 3851 l 4377 3836 l 4400 3821 l 4422 3807 l 4442 3794 l
+ 4460 3782 l 4475 3772 l 4487 3764 l 4496 3757 l
+ 4511 3747 l gs col0 s gr gr
+
+% arrowhead
+0 slj
+n 4360 3919 m 4499 3755 l 4294 3819 l 4361 3846 l 4360 3919 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+15.000 slw
+n 4500 2700 m 5850 2700 l 5850 3600 l 4500 3600 l
+ cp gs col0 s gr
+% Polyline
+n 4500 2700 m 5850 1800 l 7200 1800 l 5850 2700 l 5850 3600 l 7200 2700 l
+
+ 7200 1800 l gs col0 s gr
+% Polyline
+7.500 slw
+n 4500 3150 m
+ 5850 3150 l gs col0 s gr
+% Polyline
+n 5850 3150 m
+ 7200 2250 l gs col0 s gr
+% Polyline
+15.000 slw
+n 1350 2700 m 2700 2700 l 2700 3600 l 1350 3600 l
+ cp gs col0 s gr
+% Polyline
+n 1350 2700 m 2700 1800 l 4050 1800 l 2700 2700 l 2700 3600 l 4050 2700 l
+
+ 4050 1800 l gs col0 s gr
+% Polyline
+7.500 slw
+n 1800 3600 m 1800 2700 l
+ 3150 1800 l gs col0 s gr
+% Polyline
+n 1350 3150 m
+ 2700 3150 l gs col0 s gr
+% Polyline
+n 2700 3150 m
+ 4050 2250 l gs col0 s gr
+% Polyline
+n 6300 3285 m 6300 2385 l
+ 4950 2385 l gs col0 s gr
+% Polyline
+n 6750 3015 m 6750 2115 l
+ 5355 2115 l gs col0 s gr
+% Polyline
+n 2250 3600 m 2250 2700 l
+ 3600 1800 l gs col0 s gr
+/Times-Roman ff 190.50 scf sf
+6030 2835 m
+gs 1 -1 sc (3) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1980 3015 m
+gs 1 -1 sc (4) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+2430 3015 m
+gs 1 -1 sc (3) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1530 3015 m
+gs 1 -1 sc (5) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+2430 3420 m
+gs 1 -1 sc (0) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1980 3420 m
+gs 1 -1 sc (1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1530 3420 m
+gs 1 -1 sc (2) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6030 3330 m
+gs 1 -1 sc (0) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6480 3015 m
+gs 1 -1 sc (1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6930 2700 m
+gs 1 -1 sc (2) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6930 2250 m
+gs 1 -1 sc (5) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6435 2565 m
+gs 1 -1 sc (4) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1170 3645 m
+gs 1 -1 sc (Y) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4140 2700 m
+gs 1 -1 sc (X) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+2610 2655 m
+gs 1 -1 sc (Z) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+5760 2610 m
+gs 1 -1 sc (Z) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4275 3690 m
+gs 1 -1 sc (Y) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7290 2700 m
+gs 1 -1 sc (X) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+1755 3780 m
+gs 1 -1 sc (ncpus1) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+4455 3420 m
+gs 1 -1 sc 90.0 rot (ncpus2) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+1260 3375 m
+gs 1 -1 sc 90.0 rot (ncpus2) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+6460 3388 m
+gs 1 -1 sc 30.0 rot (ncpus1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4500 4052 m
+gs 1 -1 sc (alongY distribution) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+1342 4044 m
+gs 1 -1 sc (alongX distribution) col0 sh gr
+% here ends figure;
+$F2psEnd
+rs
+showpage
+%%Trailer
+%EOF
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.fig b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.fig
new file mode 100644
index 0000000000000000000000000000000000000000..3ff50e2244cd087a23437f3b954bfd7d2aaea54e
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.fig
@@ -0,0 +1,63 @@
+#FIG 3.2 Produced by xfig version 3.2.5
+Landscape
+Center
+Metric
+A4
+100.00
+Single
+-2
+1200 2
+2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 4500 2700 5850 2700 5850 3600 4500 3600 4500 2700
+2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 7
+ 4500 2700 5850 1800 7200 1800 5850 2700 5850 3600 7200 2700
+ 7200 1800
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 4500 3150 5850 3150
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 5850 3150 7200 2250
+2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 1350 2700 2700 2700 2700 3600 1350 3600 1350 2700
+2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 7
+ 1350 2700 2700 1800 4050 1800 2700 2700 2700 3600 4050 2700
+ 4050 1800
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 1800 3600 1800 2700 3150 1800
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 1350 3150 2700 3150
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 2700 3150 4050 2250
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 6300 3285 6300 2385 4950 2385
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 6750 3015 6750 2115 5355 2115
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 2250 3600 2250 2700 3600 1800
+3 2 0 1 0 7 51 -1 -1 0.000 0 1 0 5
+ 2 1 1.00 120.00 165.00
+ 3185 3362 3004 3716 3298 4041 3886 4048 4511 3747
+ 0.000 -1.000 -1.000 -1.000 0.000
+4 0 0 50 -1 0 12 0.0000 4 135 105 6030 2835 3\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 1980 3015 4\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 2430 3015 3\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 1530 3015 5\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 2430 3420 0\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 1980 3420 1\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 1530 3420 2\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6030 3330 0\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6480 3015 1\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6930 2700 2\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6930 2250 5\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6435 2565 4\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 1170 3645 Y\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 4140 2700 X\001
+4 0 0 50 -1 0 12 0.0000 4 135 120 2610 2655 Z\001
+4 0 0 50 -1 0 12 0.0000 4 135 120 5760 2610 Z\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 4275 3690 Y\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 7290 2700 X\001
+4 0 0 50 -1 3 12 0.0000 4 165 585 1755 3780 ncpus1\001
+4 0 0 50 -1 3 12 1.5708 4 165 585 4455 3420 ncpus2\001
+4 0 0 50 -1 3 12 1.5708 4 165 585 1260 3375 ncpus2\001
+4 0 0 50 -1 3 12 0.5236 4 165 585 6460 3388 ncpus1\001
+4 0 0 50 -1 0 12 0.0000 4 180 1605 4500 4052 alongY distribution\001
+4 0 0 50 -1 0 12 0.0000 4 180 1605 1342 4044 alongX distribution\001
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.png b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.png
new file mode 100644
index 0000000000000000000000000000000000000000..7237fe05aba08ddab9531a36db3f7a946407faf9
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/doxygen/images/xycommunicator.png differ
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.eps b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.eps
new file mode 100644
index 0000000000000000000000000000000000000000..a8dece8fba6263b1f3649b01457f5d9a2e642a74
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.eps
@@ -0,0 +1,230 @@
+%!PS-Adobe-2.0 EPSF-2.0
+%%Title: yzcommunicator.fig
+%%Creator: fig2dev Version 3.2 Patchlevel 5
+%%CreationDate: Thu Jun 30 17:40:20 2011
+%%For: begou@thor (Patrick Begou)
+%%BoundingBox: 0 0 414 149
+%Magnification: 1.0000
+%%EndComments
+%%BeginProlog
+/$F2psDict 200 dict def
+$F2psDict begin
+$F2psDict /mtrx matrix put
+/col-1 {0 setgray} bind def
+/col0 {0.000 0.000 0.000 srgb} bind def
+/col1 {0.000 0.000 1.000 srgb} bind def
+/col2 {0.000 1.000 0.000 srgb} bind def
+/col3 {0.000 1.000 1.000 srgb} bind def
+/col4 {1.000 0.000 0.000 srgb} bind def
+/col5 {1.000 0.000 1.000 srgb} bind def
+/col6 {1.000 1.000 0.000 srgb} bind def
+/col7 {1.000 1.000 1.000 srgb} bind def
+/col8 {0.000 0.000 0.560 srgb} bind def
+/col9 {0.000 0.000 0.690 srgb} bind def
+/col10 {0.000 0.000 0.820 srgb} bind def
+/col11 {0.530 0.810 1.000 srgb} bind def
+/col12 {0.000 0.560 0.000 srgb} bind def
+/col13 {0.000 0.690 0.000 srgb} bind def
+/col14 {0.000 0.820 0.000 srgb} bind def
+/col15 {0.000 0.560 0.560 srgb} bind def
+/col16 {0.000 0.690 0.690 srgb} bind def
+/col17 {0.000 0.820 0.820 srgb} bind def
+/col18 {0.560 0.000 0.000 srgb} bind def
+/col19 {0.690 0.000 0.000 srgb} bind def
+/col20 {0.820 0.000 0.000 srgb} bind def
+/col21 {0.560 0.000 0.560 srgb} bind def
+/col22 {0.690 0.000 0.690 srgb} bind def
+/col23 {0.820 0.000 0.820 srgb} bind def
+/col24 {0.500 0.190 0.000 srgb} bind def
+/col25 {0.630 0.250 0.000 srgb} bind def
+/col26 {0.750 0.380 0.000 srgb} bind def
+/col27 {1.000 0.500 0.500 srgb} bind def
+/col28 {1.000 0.630 0.630 srgb} bind def
+/col29 {1.000 0.750 0.750 srgb} bind def
+/col30 {1.000 0.880 0.880 srgb} bind def
+/col31 {1.000 0.840 0.000 srgb} bind def
+
+end
+save
+newpath 0 149 moveto 0 0 lineto 414 0 lineto 414 149 lineto closepath clip newpath
+-268.3 260.1 translate
+1 -1 scale
+
+/cp {closepath} bind def
+/ef {eofill} bind def
+/gr {grestore} bind def
+/gs {gsave} bind def
+/sa {save} bind def
+/rs {restore} bind def
+/l {lineto} bind def
+/m {moveto} bind def
+/rm {rmoveto} bind def
+/n {newpath} bind def
+/s {stroke} bind def
+/sh {show} bind def
+/slc {setlinecap} bind def
+/slj {setlinejoin} bind def
+/slw {setlinewidth} bind def
+/srgb {setrgbcolor} bind def
+/rot {rotate} bind def
+/sc {scale} bind def
+/sd {setdash} bind def
+/ff {findfont} bind def
+/sf {setfont} bind def
+/scf {scalefont} bind def
+/sw {stringwidth} bind def
+/tr {translate} bind def
+/tnt {dup dup currentrgbcolor
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add
+ 4 -2 roll dup 1 exch sub 3 -1 roll mul add srgb}
+ bind def
+/shd {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul
+ 4 -2 roll mul srgb} bind def
+/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def
+/$F2psEnd {$F2psEnteredState restore end} def
+
+$F2psBegin
+10 setmiterlimit
+0 slj 0 slc
+ 0.06299 0.06299 sc
+%%EndProlog
+%
+% Fig objects follow
+%
+%
+% here starts figure with depth 51
+% Arc
+7.500 slw
+0 slc
+gs clippath
+6695 3364 m 6574 3566 l 6677 3627 l 6798 3425 l 6798 3425 l 6641 3572 l 6695 3364 l cp
+eoclip
+n 7125.6 3774.7 527.3 35.6485 -158.7948 arcn
+gs col0 s gr
+ gr
+
+% arrowhead
+0 slj
+n 6695 3364 m 6641 3572 l 6798 3425 l 6725 3430 l 6695 3364 l
+ cp gs 0.00 setgray ef gr col0 s
+% Polyline
+15.000 slw
+n 4500 2700 m 5850 2700 l 5850 3600 l 4500 3600 l
+ cp gs col0 s gr
+% Polyline
+n 4500 2700 m 5850 1800 l 7200 1800 l 5850 2700 l 5850 3600 l 7200 2700 l
+
+ 7200 1800 l gs col0 s gr
+% Polyline
+7.500 slw
+n 4500 3150 m
+ 5850 3150 l gs col0 s gr
+% Polyline
+n 5850 3150 m
+ 7200 2250 l gs col0 s gr
+% Polyline
+n 6300 3285 m 6300 2385 l
+ 4950 2385 l gs col0 s gr
+% Polyline
+n 6750 3015 m 6750 2115 l
+ 5355 2115 l gs col0 s gr
+% Polyline
+15.000 slw
+n 7863 2702 m 9213 2702 l 9213 3602 l 7863 3602 l
+ cp gs col0 s gr
+% Polyline
+n 7863 2702 m 9213 1802 l 10563 1802 l 9213 2702 l 9213 3602 l 10563 2702 l
+
+ 10563 1802 l gs col0 s gr
+% Polyline
+7.500 slw
+n 9879 1790 m
+ 8533 2694 l gs col0 s gr
+% Polyline
+n 10122 3003 m 10122 2084 l
+ 8761 2077 l gs col0 s gr
+% Polyline
+n 9680 3305 m 9680 2386 l
+ 8313 2393 l gs col0 s gr
+% Polyline
+n 8548 2687 m
+ 8548 3606 l gs col0 s gr
+/Times-Roman ff 190.50 scf sf
+6030 2835 m
+gs 1 -1 sc (3) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6030 3330 m
+gs 1 -1 sc (0) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6480 3015 m
+gs 1 -1 sc (1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6930 2700 m
+gs 1 -1 sc (2) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6930 2250 m
+gs 1 -1 sc (5) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+6435 2565 m
+gs 1 -1 sc (4) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+5760 2610 m
+gs 1 -1 sc (Z) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4275 3690 m
+gs 1 -1 sc (Y) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7290 2700 m
+gs 1 -1 sc (X) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+4455 3420 m
+gs 1 -1 sc 90.0 rot (ncpus2) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+6460 3388 m
+gs 1 -1 sc 30.0 rot (ncpus1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+10671 2692 m
+gs 1 -1 sc (X) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7683 3647 m
+gs 1 -1 sc (Y) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+9031 2614 m
+gs 1 -1 sc (0) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+9544 2304 m
+gs 1 -1 sc (1) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+9918 2003 m
+gs 1 -1 sc (2) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8347 2591 m
+gs 1 -1 sc (3) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+8817 2282 m
+gs 1 -1 sc (4) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+9264 2002 m
+gs 1 -1 sc (5) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+9804 3456 m
+gs 1 -1 sc 30.0 rot (ncpus1) col0 sh gr
+/Times-BoldItalic ff 190.50 scf sf
+8270 3780 m
+gs 1 -1 sc (ncpus2) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+9049 2907 m
+gs 1 -1 sc (Z) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+4512 4060 m
+gs 1 -1 sc (alongY distribution) col0 sh gr
+/Times-Roman ff 190.50 scf sf
+7853 4037 m
+gs 1 -1 sc (alongZ distribution) col0 sh gr
+% here ends figure;
+$F2psEnd
+rs
+showpage
+%%Trailer
+%EOF
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.fig b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.fig
new file mode 100644
index 0000000000000000000000000000000000000000..be95b8cffe359a9ad59111684da9bf0933d36236
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.fig
@@ -0,0 +1,61 @@
+#FIG 3.2 Produced by xfig version 3.2.5
+Landscape
+Center
+Metric
+A4
+100.00
+Single
+-2
+1200 2
+5 1 0 1 0 7 51 -1 -1 0.000 0 1 1 0 7125.552 3774.712 7554 4082 7418 3336 6634 3584
+ 2 1 1.00 120.00 165.00
+2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 4500 2700 5850 2700 5850 3600 4500 3600 4500 2700
+2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 7
+ 4500 2700 5850 1800 7200 1800 5850 2700 5850 3600 7200 2700
+ 7200 1800
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 4500 3150 5850 3150
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 5850 3150 7200 2250
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 6300 3285 6300 2385 4950 2385
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 6750 3015 6750 2115 5355 2115
+2 2 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 5
+ 7863 2702 9213 2702 9213 3602 7863 3602 7863 2702
+2 1 0 2 0 7 50 -1 -1 0.000 0 0 -1 0 0 7
+ 7863 2702 9213 1802 10563 1802 9213 2702 9213 3602 10563 2702
+ 10563 1802
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 9879 1790 8533 2694
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 10122 3003 10122 2084 8761 2077
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3
+ 9680 3305 9680 2386 8313 2393
+2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2
+ 8548 2687 8548 3606
+4 0 0 50 -1 0 12 0.0000 4 135 105 6030 2835 3\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6030 3330 0\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6480 3015 1\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6930 2700 2\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6930 2250 5\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 6435 2565 4\001
+4 0 0 50 -1 0 12 0.0000 4 135 120 5760 2610 Z\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 4275 3690 Y\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 7290 2700 X\001
+4 0 0 50 -1 3 12 1.5708 4 165 585 4455 3420 ncpus2\001
+4 0 0 50 -1 3 12 0.5236 4 165 585 6460 3388 ncpus1\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 10671 2692 X\001
+4 0 0 50 -1 0 12 0.0000 4 135 135 7683 3647 Y\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 9031 2614 0\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 9544 2304 1\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 9918 2003 2\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 8347 2591 3\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 8817 2282 4\001
+4 0 0 50 -1 0 12 0.0000 4 135 105 9264 2002 5\001
+4 0 0 50 -1 3 12 0.5236 4 165 585 9804 3456 ncpus1\001
+4 0 0 50 -1 3 12 0.0000 4 165 585 8270 3780 ncpus2\001
+4 0 0 50 -1 0 12 0.0000 4 135 120 9049 2907 Z\001
+4 0 0 50 -1 0 12 0.0000 4 180 1605 4512 4060 alongY distribution\001
+4 0 0 50 -1 0 12 0.0000 4 180 1590 7853 4037 alongZ distribution\001
diff --git a/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.png b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.png
new file mode 100644
index 0000000000000000000000000000000000000000..6a87434637ccec072559ae23894300d310764ca4
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/doc/doxygen/images/yzcommunicator.png differ
diff --git a/HySoP/src/Unstable/LEGI/example/CMakeLists.txt b/HySoP/src/Unstable/LEGI/example/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..febd4f0ab6f826fc669a9047b2c86fd7dc8c351d
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/example/CMakeLists.txt
@@ -0,0 +1 @@
+add_subdirectory(src)
diff --git a/HySoP/src/Unstable/LEGI/example/advec/shear_tag b/HySoP/src/Unstable/LEGI/example/advec/shear_tag
new file mode 100755
index 0000000000000000000000000000000000000000..6d8fb7de7294159d887edb1d63b56d5bc437afd2
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/example/advec/shear_tag differ
diff --git a/HySoP/src/Unstable/LEGI/example/advec/turn_sphere b/HySoP/src/Unstable/LEGI/example/advec/turn_sphere
new file mode 100755
index 0000000000000000000000000000000000000000..5f9e61b8db4885a59e619527d4779ccdf4113100
Binary files /dev/null and b/HySoP/src/Unstable/LEGI/example/advec/turn_sphere differ
diff --git a/HySoP/src/Unstable/LEGI/example/src/CMakeLists.txt b/HySoP/src/Unstable/LEGI/example/src/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..e12c5b53904c7ffd8d5fdaa105a66000751e62e3
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/example/src/CMakeLists.txt
@@ -0,0 +1,45 @@
+set(EXECUTABLE_OUTPUT_PATH "${EXAMPLE_EXE_DIR}")
+include_directories(${CMAKE_Fortran_MODULE_DIRECTORY})
+
+# ===== Example and benchmark about advection equation and the particular solver =====
+set(EXECUTABLE_OUTPUT_PATH "${EXAMPLE_EXE_DIR}/advec")
+# --- Simple turning sphere ---
+set(EXAMPLE_NAME turn_sphere)
+ # Test file
+ list(APPEND ${EXAMPLE_NAME}_SRC "advec/${EXAMPLE_NAME}.f90")
+ list(APPEND ${EXAMPLE_NAME}_SRC "../../test/src/test_common.f90")
+ list(APPEND ${EXAMPLE_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/input_output/vtkxml.f90")
+ # General environment and utilities (mesh, io, ...)
+ file(GLOB ${EXAMPLE_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/layout/cart*.f90 )
+ if(${EXAMPLE_NAME}_LIB)
+ list(APPEND ${EXAMPLE_NAME}_SRC ${${EXAMPLE_NAME}_LIB})
+ endif()
+ # Particular solver
+ file(GLOB ${EXAMPLE_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/particle/*.f90)
+ if(${EXAMPLE_NAME}_LIB)
+ list(APPEND ${EXAMPLE_NAME}_SRC ${${EXAMPLE_NAME}_LIB})
+ endif()
+add_executable(${EXAMPLE_NAME} ${${EXAMPLE_NAME}_SRC})
+target_link_libraries(${EXAMPLE_NAME} ${LIBS})
+
+# --- Case test with shear ---
+# In this example, velocity radial component vanishes and as scalar is initialized with cylindric symetry, it stays constant.
+# It allow to compare solver with large time step (eg cfl number bigger than one)
+set(EXAMPLE_NAME shear_tag)
+ # Test file
+ list(APPEND ${EXAMPLE_NAME}_SRC "advec/${EXAMPLE_NAME}.f90")
+ list(APPEND ${EXAMPLE_NAME}_SRC "../../test/src/test_common.f90")
+ list(APPEND ${EXAMPLE_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/input_output/vtkxml.f90")
+ # General environment and utilities (mesh, io, ...)
+ file(GLOB ${EXAMPLE_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/layout/cart*.f90 )
+ if(${EXAMPLE_NAME}_LIB)
+ list(APPEND ${EXAMPLE_NAME}_SRC ${${EXAMPLE_NAME}_LIB})
+ endif()
+ # Particular solver
+ file(GLOB ${EXAMPLE_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/particle/*.f90)
+ if(${EXAMPLE_NAME}_LIB)
+ list(APPEND ${EXAMPLE_NAME}_SRC ${${EXAMPLE_NAME}_LIB})
+ endif()
+add_executable(${EXAMPLE_NAME} ${${EXAMPLE_NAME}_SRC})
+target_link_libraries(${EXAMPLE_NAME} ${LIBS})
+
diff --git a/HySoP/src/Unstable/LEGI/example/src/advec/shear_tag.f90 b/HySoP/src/Unstable/LEGI/example/src/advec/shear_tag.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4451438c6276eaed889649aee5064632985e70f9
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/example/src/advec/shear_tag.f90
@@ -0,0 +1,161 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : advec_sheartag
+!
+! DESCRIPTION:
+!> This program provide a numerical illustration of an adveciton problem: a
+!! velocity field with radial shear. This test illustrate the effect of
+!corrected remeshing formula.
+!!
+!! @details
+!! This example could be used as a benchmark (to determine optimisation
+!! efficiency or parallel scalability). The velocity field is choosen to ensure
+!! That the solver will imply tag and thus corrected remeshing formula. It is a
+!! Typical test cases to evaluate efficiency of such a formula in context of large
+!! Cfl number (eg 3 or more).
+!! Note that the analyti solution is known and could be check.
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program advec_sheartag
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ use advec
+ use vtkxml
+ ! Test procedures
+ use test_common
+
+ implicit none
+
+ logical, parameter :: output = .false. ! Do you want output for
+ ! vizualisation purpose ?
+ real(WP), parameter :: M_PI = ACOS(-1.0) ! Pi value
+ real(WP),parameter :: period = 1
+
+ logical :: success = .true. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc,nb_procZ ! number of processus
+
+ character(str_short) :: order='p_02' ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: Vx, Vy, VZ ! the flow
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ integer :: i,j,k ! mesh indice
+ real(WP) :: T_step ! time where output are done
+ real(WP) :: T_end ! final time
+ real(WP) :: T ! current time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ integer :: tag_num,tag_err ! identifiant for io
+ integer :: tag_sol ! identifiant for io
+ real(WP) :: rx, ry, rr
+ integer, parameter :: N_mesh=400 ! number of mesh
+
+ ! ===== Initialisation of parallel context =====
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .true.
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! ===== Cut the domain along y and initialize the topology =====
+ nb_procZ = 1
+ if (mod(N_mesh, nb_proc)/=0) stop 'wrong number of processes : it have to divide 100'
+ call cart_create((/ nb_proc, nb_procZ /), ierr)
+
+ ! ===== Create mesh =====
+ call discretisation_create(N_mesh,N_mesh,20,dble(2),dble(2),dble(0.5))
+ call set_group_size(5)
+ call advec_init(order)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! ===== Field allocation =====
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vx(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vz(N_proc(1), N_proc(2), N_proc(3)))
+
+ ! ===== Initialization ====
+ Vx = 0.0
+ Vy = 0.0
+ Vz = 0.0
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ ry = ((j-1+coord(2)*N_proc(2))*d_sc(2)) - length(2)/2.0
+ do i = 1, N_proc(1)
+ rx = ((i-1+coord(1)*N_proc(1))*d_sc(1))-length(1)/2.0
+ rr = (rx**2+ry**2)
+ if (rr<1) then
+ scal3D(i,j,k) = (1-rr)**6
+ else
+ scal3D(i,j,k) = 0
+ end if
+ Vx(i,j,k) = cos(3*M_PI*sqrt(rr)/2)*(-ry)
+ Vy(i,j,k) = cos(3*M_PI*sqrt(rr)/2)*(rx)
+ end do
+ end do
+ end do
+ good_scal = scal3D
+ T = 0.0
+ dt = 3*min(d_sc(1),d_sc(2))
+ T_step = 0.0
+ T_end = 0.8
+ call test_substatus('cfl=3 and dt', dt, cart_rank)
+
+ ! === Create output context and solve initial state =====
+ if (output) then
+ call vtkxml_init_all(9, nb_proc_dim, length, cart_rank, coord,'./adv_res/')
+ call vtkxml_init_field(trim(order)//'_tag_num', tag_num)
+ call vtkxml_init_field(trim(order)//'_tag_err', tag_err)
+ call vtkxml_init_field(trim(order)//'_tag_sol', tag_sol)
+ call vtkxml_write(tag_sol, good_scal)
+ end if
+
+
+ ! ===== Solve equation ====
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('tag, t', T, cart_rank)
+ if (output) call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ if (output) then
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call vtkxml_finish()
+ end if
+ call test_substatus ('time', (T+dt), cart_rank)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - with tag', success, cart_rank)
+
+
+ ! --- Free memory ---
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(Vx)
+ deallocate(Vy)
+ deallocate(Vz)
+
+ success = .not.success
+
+ call mpi_finalize(ierr)
+
+end program advec_sheartag
diff --git a/HySoP/src/Unstable/LEGI/example/src/advec/turn_sphere.f90 b/HySoP/src/Unstable/LEGI/example/src/advec/turn_sphere.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d87c3c9855c0c62ebfa695309db630a84c6f550d
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/example/src/advec/turn_sphere.f90
@@ -0,0 +1,186 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : advec_turnsphere
+!
+! DESCRIPTION:
+!> This program provide a numerical illustration of an adveciton problem: a
+!! turning sphere.
+!!
+!! @details
+!! This example could be used as a benchmark (to determine optimisation
+!! efficiency or parallel scalability)
+!! Note that the analyti solution is known and could be check.
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program advec_turnsphere
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use advec
+ use cart_topology
+ use vtkxml
+ ! Test procedures
+ use test_common
+
+ implicit none
+
+ real(WP), parameter :: M_PI = ACOS(-1.0) ! Pi value
+ logical, parameter :: output = .true. ! Do you want output for
+ ! vizualisation purpose ?
+ real(WP),parameter :: period = 1
+ integer, parameter :: mesh_size = 160
+
+ logical :: success = .true. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc,nb_procZ ! number of processus
+
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: Vx, Vy, Vz ! the flow
+ integer :: i,j,k ! mesh indice
+ real(WP) :: rx, ry, rz, rr ! distance**2 to the mesh center
+ real(WP) :: rayon ! rayon of the initial scalar sphere
+ real(WP) :: T ! time
+ real(WP) :: T_end ! final time
+ real(WP) :: T_ite ! time corresponding to output
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(:, :, :), allocatable :: good_velo ! temp field
+ integer :: tag_rot ! tag for visualisation context
+ integer :: tag_sol ! tag for visualisation context
+ real(WP) :: times, time1, time2 ! to evaluate computation time.
+
+ ! ===== Initialisation of parallel context =====
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .true.
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ nb_procZ = 1
+ if ((mod(nb_proc,5)==0).and.(mod(mesh_size, nb_proc/5)==0)) then
+ nb_procZ = 5
+ nb_proc = nb_proc/5
+ else if ((mod(nb_proc,2)==0).and.(mod(mesh_size, nb_proc/2)==0)) then
+ nb_procZ = 2
+ nb_proc = nb_proc/2
+ else
+ if (mod(mesh_size, nb_proc)/=0) then
+ if(cart_rank==0) write(*,'(a,x,i0)') 'wrong number of processes : it have to divide', mesh_size
+ stop
+ end if
+ end if
+
+ ! ===== Create mesh ====
+ call cart_create((/ nb_proc, nb_procZ /), ierr)
+ call set_group_size(5)
+ call discretisation_create(mesh_size,mesh_size,mesh_size,dble(1),dble(1),dble(1))
+ call test_substatus('group size', group_size(1,1), cart_rank)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! ===== Initialize the particular solver =====
+ call advec_init('p_O2')
+
+ ! ===== Field allocation =====
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vx(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vz(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_velo(N_proc(1), N_proc(2), N_proc(3)))
+
+ ! ===== Initialization ====
+ ! -- Scalar --
+ scal3D = 0.
+ rayon = (minval(N*d_sc)/10.0)**2
+ do k = 1, N_proc(3)
+ rz = (d_sc(3)*(k + coord(3)*N_proc(3) - 3.0*N(3)/5.0))**2
+ do j = 1, N_proc(2)
+ ry = (d_sc(2)*(j + coord(2)*N_proc(2)- 3.0*N(2)/5.0))**2
+ do i = 1, N_proc(1)
+ rx = (d_sc(1)*(i - 3.0*N(1)/5.0))**2
+ rr = rx + ry + rz
+ if (rr < rayon) scal3D(i,j,k) = (1 - rr/rayon)**1
+ end do
+ end do
+ end do
+ good_scal = scal3D
+ ! -- Velocity --
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ Vx(i,j,k)=(2*M_PI/period)*(length(2)/2.0-((j+coord(2)*N_proc(2))*d_sc(2)))
+ Vy(i,j,k)=(2*M_PI/period)*(((i+coord(1)*N_proc(1))*d_sc(1))-length(1)/2.0)
+ end do
+ end do
+ end do
+ Vz = 0.0
+
+
+
+ ! ===== Initialize output context ====
+ if (output) then
+ call vtkxml_init_all(2, nb_proc_dim, length, cart_rank, coord,'./adv_res/')
+ call vtkxml_init_field('turning', tag_rot)
+ call vtkxml_init_field('turn_sol', tag_sol)
+ call vtkxml_write(tag_rot, scal3D, 'turning')
+ end if
+
+
+ ! ===== Compute the numerical solution =====
+ dt = 0.02
+ T = 0
+ T_end = 2*period
+ T_ite = 0
+ times = 0
+ do while (T<=T_end - dt)
+ call cpu_time(time1)
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ call cpu_time(time2)
+ times=times+(time2-time1)
+ if (T>T_ite) then
+ T_ite = T_ite + T_end/10
+ call test_substatus ('time', T, cart_rank)
+ if (output) call vtkxml_write(tag_rot, scal3D, 'turning')
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ if (output) then
+ call vtkxml_write(tag_rot, scal3D, 'turning')
+ call vtkxml_write(tag_sol, good_scal)
+ call vtkxml_finish()
+ end if
+
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+print*, 'times = ', times
+ call test_substatus('computational time', times, cart_rank)
+ call test_substatus('turning sphere', success, cart_rank)
+
+
+ ! --- Free memory ---
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(Vx)
+ deallocate(Vy)
+ deallocate(Vz)
+
+ success = .not.success
+
+
+ call mpi_finalize(ierr)
+
+end program advec_turnsphere
diff --git a/HySoP/src/Unstable/LEGI/test/src/CMakeLists.txt b/HySoP/src/Unstable/LEGI/test/src/CMakeLists.txt
new file mode 100644
index 0000000000000000000000000000000000000000..f72a850e46326ee83100366167814046dba1cbe5
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/CMakeLists.txt
@@ -0,0 +1,53 @@
+set(EXECUTABLE_OUTPUT_PATH "${TEST_EXE_DIR}")
+include_directories(${CMAKE_Fortran_MODULE_DIRECTORY})
+
+# ===== Test the parallel topology and how it interact with the "global" datalayout (used in the spectral code) =====
+set(TEST_NAME Test_topo)
+ file(GLOB ${TEST_NAME}_FILES ${TEST_NAME}/*.f90)
+ if(${TEST_NAME}_FILES)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_FILES})
+ endif()
+ list(APPEND ${TEST_NAME}_SRC "test_common.f90")
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_topology.f90")
+add_executable(${TEST_NAME} ${${TEST_NAME}_SRC})
+target_link_libraries(${TEST_NAME} ${LIBS})
+
+# ===== Test the parallel output =====
+set(TEST_NAME Test_io)
+ file(GLOB ${TEST_NAME}_FILES ${TEST_NAME}/*.f90)
+ if(${TEST_NAME}_FILES)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_FILES})
+ endif()
+ list(APPEND ${TEST_NAME}_SRC "test_common.f90")
+ # Tested procedures
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_topology.f90")
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_mesh.f90")
+ file(GLOB ${TEST_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/output/*.f90)
+ if(${TEST_NAME}_LIB)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_LIB})
+ endif()
+add_executable(${TEST_NAME} ${${TEST_NAME}_SRC})
+target_link_libraries(${TEST_NAME} ${LIBS})
+
+# ===== Test the advection and the particular solver =====
+set(TEST_NAME Test_advec)
+ # Test file
+ file(GLOB ${TEST_NAME}_FILES ${TEST_NAME}/*.f90)
+ if(${TEST_NAME}_FILES)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_FILES})
+ endif()
+ list(APPEND ${TEST_NAME}_SRC "test_common.f90")
+ # General environment and utilities (mesh, io, ...)
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_topology.f90")
+ list(APPEND ${TEST_NAME}_SRC "${${EXE_NAME}_SRCDIRS}/cart_mesh.f90")
+ file(GLOB ${TEST_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/output/*.f90)
+ if(${TEST_NAME}_LIB)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_LIB})
+ endif()
+ # Tested solver
+ file(GLOB ${TEST_NAME}_LIB ${${EXE_NAME}_SRCDIRS}/particle/*.f90)
+ if(${TEST_NAME}_LIB)
+ list(APPEND ${TEST_NAME}_SRC ${${TEST_NAME}_LIB})
+ endif()
+add_executable(${TEST_NAME} ${${TEST_NAME}_SRC})
+target_link_libraries(${TEST_NAME} ${LIBS})
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b2a738caea7b3885ad270086d3e0d22212094ac5
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux.f90
@@ -0,0 +1,775 @@
+!> @addtogroup part_test
+!! @{
+
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection
+!
+! DESCRIPTION:
+!> Validation test for advection method.
+!!
+!! @details
+!! This module provide different test to validate the transport solver.
+!! All these test are unit test : they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular solver
+!! The following test are included :
+!! A - Validate the particular method, step by step
+!! 1 -> Test the procedure "AC_obtain_senders" from advec_common
+!! 2 -> Validate the redistribution the buffer during the remeshing (XXX todo)
+!! 3 -> Validate the remeshing of untagged particles
+!! 4 -> Validate the remeshing of tagged particles (XXX todo)
+!! B - Validate an advection solver (XXX todo)
+!! 1 -> advec a ball with a constant velocity
+!! 2 -> advec a ball with a spheric velocity field (the ball turns)
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module advec_aux
+
+ use string
+ use precision
+ implicit none
+
+ real(WP), private :: epsilon_error = 1e-4 ! Error tolerance
+
+
+ ! Public procedures
+
+ ! ===== Test for the particles solver =====
+ ! Public function
+ public :: test_part_remesh_no_tag
+ public :: test_part_advec_1D
+ public :: test_part_advec_3D
+ public :: test_advecY
+
+
+ ! ===== Generic test for an advection solver =====
+
+ ! Private procedure
+
+contains
+
+!> Particles method: validation of the remeshing of untagged particles
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @param[in] order_opt = optional parameter to choose the remeshing formula
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_remesh_no_tag (init_scal, order_opt) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+ character(len=*), intent(in), optional :: order_opt ! space order of the solveur
+
+ character(len=17) :: initialisation ! to choose how to initialise the scalar field
+ character(len=str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scalar ! the scalar field
+ real(WP), dimension(:,:,:), allocatable :: p_pos_adim, p_SC ! the adimensionned particles position and the scalar they advect
+ logical, dimension(:,:,:), allocatable :: bl_type, bl_tag ! type and tag of each particle bloc
+ real(WP) :: velocity ! constant velocity of the flux
+ integer :: nb_proc ! number of processes
+ integer :: ierr ! mpi error code
+ integer :: i,j,k ! mesh indice
+ integer, dimension(2) :: ind_group ! indice of the current group of line
+ integer :: T_step ! time
+ integer :: T_end ! final time
+ real(WP), dimension(:,:,:), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(3) :: translat ! to compute analytic solution
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ if (present(order_opt)) order = trim(order_opt)
+ call advec_init(order)
+
+ allocate(scalar(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(p_pos_adim(N_proc(2),1,1))
+ allocate(p_SC(N_proc(2),1,1))
+ allocate(bl_type(1+N_proc(2)/bl_size,1,1))
+ allocate(bl_tag((N_proc(2)/bl_size),1,1))
+
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'constant'
+ end if
+ success = .true.
+
+ !call cart_create((/ 1, nb_proc, 1 /), ierr)
+ !call mesh_default()
+
+ ! Choose a velocity
+ velocity = N(2)/11.*d_sc(2)
+ T_step = 1
+ T_end = 1
+ T_end = T_step
+ translat = 0
+ translat(2) = - velocity*T_step
+ translat = translat/d_sc
+
+ ! Initialise the scalar field
+ call scal_init(initialisation, scalar, good_scal, translat)
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Choose to test remeshing for centered/left and tagged/untagged particles
+ bl_type = .true.
+ bl_tag = .false.
+
+ ! Advec it with a particular method
+ do k = begin_proc(3), end_proc(3)
+ ind_group(2) = 0
+ !k = begin_proc(3)
+ ind_group(1) = 0
+ ind_group(2) = ind_group(2) + 1
+ do i = begin_proc(1), end_proc(1)
+ !i = begin_proc(1)
+ ind_group(1) = ind_group(1) + 1
+ ! Initialise the particles
+ p_SC(:,1,1) = scalar(i,:,k)
+ !scalar(i,:,k)=0
+ do j = begin_proc(2), end_proc(2)
+ p_pos_adim(j,1,1) = j
+ end do
+! do T_step = 1, 11
+ ! Advection
+ p_pos_adim = p_pos_adim + T_step*velocity/d_sc(2)
+ ! Remeshing
+ allocate(send_group_min(1,1))
+ allocate(send_group_max(1,1))
+ if (order == 'p_O4') then
+ call Yremesh_O4(ind_group, (/1,1/), p_pos_adim, bl_type, bl_tag, i, k, scalar)
+ else if (order == 'p_M6') then
+ call Yremesh_Mprime6(ind_group, (/1,1/), p_pos_adim, i, k, scalar)
+ else
+ call Yremesh_O2_group(ind_group, (/1,1/), p_pos_adim, bl_type, bl_tag, i, k, scalar)
+ end if
+ deallocate(send_group_min)
+ deallocate(send_group_max)
+! end do
+ end do
+ end do
+
+ ! Check the final scalar field
+ call test_check_success(scalar, good_scal, success, cart_rank)
+
+ deallocate(scalar)
+ deallocate(p_pos_adim)
+ deallocate(p_SC)
+ deallocate(bl_type)
+ deallocate(bl_tag)
+
+ success = .not.success
+
+end function test_part_remesh_no_tag
+
+
+!> Particles method: validation of the advection along each direction
+!! individually with particle method - no tag case.
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @param[in] shift = global translation of indices (optional)
+!! @param[in] order_opt = optional parameter to choose the remeshing formula
+!! @return error = test error (= false if the code pass the test) (= not success)
+!! @details
+!! These tests are devoted to validate the advection solver based on particle
+!! method. They can be used for other advection solvers too. Their specificity
+!! is to test each configuration that could be encoutered in the order 2 solver
+!! based on particle method. Therefore they test all cases without tag (and there-
+!! fore corrected remeshing formula) for order 2 (or order 4) solver.
+function test_part_advec_1D(init_scal, shift, order_opt) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecX
+ use advecY
+ use advecZ
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+ integer, intent(in), optional :: shift
+ character(len=*), intent(in), optional :: order_opt ! space order of the solveur
+
+ character(str_short) :: initialisation ! to choose how to initialise the fields
+ integer :: shift_bis ! shift effectly used in the test
+ character(str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: velo ! the flow
+ real(WP), dimension(:, :, :), allocatable :: Vx, Vy, VZ ! the flow
+ integer :: i,j,k ! mesh indice
+ real(WP) :: T_step ! time where output are done
+ real(WP) :: T_end ! final time
+ real(WP) :: T ! current time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ integer :: direction ! current direction
+ integer :: tag_io,tag_er ! identifiant for io
+ integer :: tag_sol ! identifiant for io
+
+ ! -- Mesh init --
+ call discretisation_create(80,80,80,dble(1),dble(1),dble(1))
+
+ ! -- Allocation --
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(velo(N_proc(1), N_proc(2), N_proc(3)))
+
+ ! -- Initialisation --
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'center'
+ end if
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ success = .true.
+ dt = 0.1
+
+ call test_substatus('shift', shift_bis, cart_rank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ if (present(order_opt)) order = order_opt
+ call advec_init(order)
+
+ ! ===== Test along X =====
+ ! Initialise the velocity, the scalar field and compute the theoritical solution
+ direction = 1
+ call test_substatus('direction', direction, cart_rank)
+ call scal_velo_init_part(init_scal, dt, shift_bis, scal3D, velo, direction, good_scal)
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Advec it with a particular method
+ call advecX_calc(dt, velo, scal3D, order)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('advection along X', success, cart_rank)
+
+
+ ! ===== Test along Y =====
+ ! Initialise the velocity, the scalar field and compute the theoritical solution
+ direction = 2
+ call test_substatus('direction', direction, cart_rank)
+ call scal_velo_init_part(init_scal, dt, shift_bis, scal3D, velo, direction, good_scal)
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Advec it with a particular method
+ call advecY_calc(dt, velo, scal3D, order)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('advection along Y', success, cart_rank)
+
+
+ ! ===== Test along Z =====
+ ! Initialise the velocity, the scalar field and compute the theoritical solution
+ direction = 3
+ call test_substatus('direction', direction, cart_rank)
+ call scal_velo_init_part(init_scal, dt, shift_bis, scal3D, velo, direction, good_scal)
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Advec it with a particular method
+ call advecZ_calc(dt, velo, scal3D, order)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('advection along Z', success, cart_rank)
+
+
+
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(velo)
+
+ success = .not.success
+
+end function test_part_advec_1D
+
+
+!> Particles method: validation of the advection in 3D cases.
+!! @param[in] order = optional parameter to choose between order 2
+!! or order 4 particle method.
+!! @param[in] shift = global translation of indices (optional)
+!! @return error = test error (= false if the code pass the test) (= not success)
+!! @details
+!! This tests are devoted to validate the advection solver based on particle
+!! method on 3D cases. They can be used for other advection solvers too. Their specificity
+!! is to test each configuration that could be encoutered in the order 2 and order 4
+!! solver based on particle method. Supposing the 1D tests (test_part_advec_1D) have been
+!! passed successful, then passed this test means the solver does not contain
+!! error anymore.
+function test_part_advec_3D(shift, order) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use cart_topology
+ use vtkxml
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: order
+ integer, intent(in), optional :: shift
+
+ character(str_short) :: initialisation ! to choose how to initialise the fields
+ integer :: shift_bis ! shift effectly used in the test
+ character(str_short) :: order_bis ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: velo ! the flow
+ real(WP), dimension(:, :, :), allocatable :: Vx, Vy, VZ ! the flow
+ integer :: i,j,k ! mesh indice
+ real(WP) :: T_step ! time where output are done
+ real(WP) :: T_end ! final time
+ real(WP) :: T ! current time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ integer :: direction ! current direction
+ integer :: tag_num,tag_err ! identifiant for io
+ integer :: tag_sol ! identifiant for io
+ real(WP) :: rx, ry, rz, rr
+
+
+ ! -- Parameters initialisation --
+ call discretisation_create(80,80,80,dble(1),dble(1),dble(1))
+ call set_group_size(10)
+ if(present(order)) then
+ order_bis = order
+ else
+ order_bis = 'p_O2'
+ end if
+ ! Initialize the particular solver
+ call advec_init(order_bis)
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, cart_rank)
+ success = .true.
+ T_end = 1.0
+
+ ! -- Allocation --
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(velo(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vx(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vz(N_proc(1), N_proc(2), N_proc(3)))
+
+ ! Initialize output context
+ call vtkxml_init_all(9, nb_proc_dim, length, cart_rank, coord,'./adv_res/')
+
+ ! -- Fields initialisation --
+ ! ===== 3D velocity =====
+ ! Initialise the velocity, the scalar field and compute the theoritical solution
+ dt = 1
+ call scal_velo_init_part('center', dt, shift_bis, scal3D, velo, 1, good_scal)
+ dt = 0.1
+ good_scal = scal3D
+ velo = 1
+ call test_substatus('Start test : X,Y,Z,3D,tag', cart_rank)
+
+
+ ! === Velocity along X ===
+ T = 0.0
+ T_step = 0.0
+ Vx = velo
+ Vy = 0
+ Vz = 0
+ call vtkxml_init_field(trim(order_bis)//'_X_num', tag_num)
+ call vtkxml_init_field(trim(order_bis)//'_X_err', tag_err)
+ call vtkxml_init_field(trim(order_bis)//'_X_sol', tag_sol)
+ call vtkxml_write(tag_sol, good_scal)
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('X, t', T, cart_rank)
+ call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call test_substatus ('X, t', (T+dt), cart_rank)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - V along X', success, cart_rank)
+
+ ! === Velocity along Y ===
+ T = 0.0
+ T_step = 0.0
+ Vx = 0
+ Vy = velo
+ Vz = 0
+ call vtkxml_init_field(trim(order_bis)//'_Y_num', tag_num)
+ call vtkxml_init_field(trim(order_bis)//'_Y_err', tag_err)
+ scal3D = good_scal
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('Y, t', T, cart_rank)
+ call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - V along Y', success, cart_rank)
+
+ ! === Velocity along Z ===
+ T = 0.0
+ T_step = 0.0
+ Vx = 0
+ Vy = 0
+ Vz = velo
+ dt = 0.1
+ T_end = 1
+ scal3D = good_scal
+ call vtkxml_init_field(trim(order_bis)//'_Z_num', tag_num)
+ call vtkxml_init_field(trim(order_bis)//'_Z_err', tag_err)
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('Z, t', T, cart_rank)
+ call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - V along Z', success, cart_rank)
+
+ ! === 3D Velocity ===
+ call test_substatus('3D test - 3D velocity', cart_rank)
+ T = 0.0
+ T_step = 0.0
+ Vx = 2*velo
+ Vy = velo
+ Vz = 3*velo
+ call vtkxml_init_field(trim(order_bis)//'_3Dnum', tag_num)
+ call vtkxml_init_field(trim(order_bis)//'_3Derr', tag_err)
+ scal3D = good_scal
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('3D, t', T, cart_rank)
+ call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - 3D velo', success, cart_rank)
+
+ ! --- Free memory ---
+ call vtkxml_finish()
+ deallocate(Vx)
+ deallocate(Vy)
+ deallocate(Vz)
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(velo)
+
+ ! === Case with corrected remeshing formula ===
+ call discretisation_create(400,400,16,dble(2),dble(2),dble(0.5))
+ call set_group_size(40)
+ call advec_init(order_bis)
+ ! -- Allocation --
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vx(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vz(N_proc(1), N_proc(2), N_proc(3)))
+ ! Initialize output context
+ call vtkxml_init_all(9, nb_proc_dim, length, cart_rank, coord,'./adv_res/')
+ call vtkxml_init_field(trim(order_bis)//'_tag_num', tag_num)
+ call vtkxml_init_field(trim(order_bis)//'_tag_err', tag_err)
+ call vtkxml_init_field(trim(order_bis)//'_tag_sol', tag_sol)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ ry = ((j-1+coord(2)*N_proc(2))*d_sc(2)) - length(2)/2.0
+ do i = 1, N_proc(1)
+ rx = ((i-1+coord(1)*N_proc(1))*d_sc(1))-length(1)/2.0
+ rr = (rx**2+ry**2)
+ if (rr<1) then
+ scal3D(i,j,k) = (1-rr)**6
+ else
+ scal3D(i,j,k) = 0
+ end if
+ Vx(i,j,k) = cos(3*M_PI*sqrt(rr)/2)*(-ry)
+ Vy(i,j,k) = cos(3*M_PI*sqrt(rr)/2)*(rx)
+ end do
+ end do
+ end do
+ good_scal = scal3D
+ call vtkxml_write(tag_sol, good_scal)
+ Vz = 0.0
+ T = 0.0
+ dt = 3*min(d_sc(1),d_sc(2))
+ T_step = 0.0
+ T_end = 0.8
+ call test_substatus('cfl=3 and dt', dt, cart_rank)
+ do while(T< (T_end - dt))
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_step) then
+ T_step = T_step + period/10
+ call test_substatus ('tag, t', T, cart_rank)
+ call vtkxml_write(tag_num, scal3D)
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_num, scal3D)
+ call vtkxml_write(tag_err, scal3D-good_scal)
+ call test_substatus ('time', (T+dt), cart_rank)
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('3D test - with tag', success, cart_rank)
+
+
+ call discretisation_default()
+ call advec_init(order_bis)
+
+ ! --- Free memory ---
+ call vtkxml_finish()
+
+ success = .not.success
+
+end function test_part_advec_3D
+
+
+
+!> Test devoted to validate advection solver along one direction
+!! @param[in] init_scal = optional parameter to initialise the scalar fied to
+!! a constant one or to a sphere shape
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_advecY(init_scal) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advecY
+ use cart_topology
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ character(len=*), intent(in), optional :: init_scal
+
+ character(len=17) :: initialisation ! to choose how to initialise the scalar field
+ character(len=str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: Vy ! the flow
+ real(WP) :: velocity ! constant velocity of the flux
+ integer :: ierr ! mpi error code
+ integer :: i,j,k ! mesh indice
+ integer :: T_step ! time
+ integer :: T_end ! final time
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(3) :: translat ! to compute analytic solution
+
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+
+ if(present(init_scal)) then
+ initialisation = init_scal
+ else
+ initialisation = 'constant'
+ end if
+ success = .true.
+
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+
+
+ ! Initialise the velocity
+ velocity = N(2)/11*d_sc(2)
+ Vy = velocity
+ T_end = 1
+ dt = 0.1
+ translat = 0
+ translat(2) = - velocity*T_end
+ translat = translat/d_sc
+
+ ! Initialise the scalar field
+ call scal_init(initialisation, scal3D, good_scal, translat)
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Advec it with a particular method
+ dt = 1
+ call advecY_calc(dt, Vy, scal3D, 'p_O2')
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('advec along Y', success, cart_rank)
+
+
+ ! --- Free memory ---
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(Vy)
+
+ success = .not.success
+
+end function test_advecY
+
+
+!> Test devoted to validate the 3D advection solver
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_advec_rot() result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use cart_topology
+ use vtkxml
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+
+ character(len=17) :: init ! to choose how to initialise the scalar field
+ character(len=str_short) :: order ! space order of the solveur
+ real(WP), dimension(:, :, :), allocatable :: scal3D ! the scalar field
+ real(WP), dimension(:, :, :), allocatable :: VX, Vy, Vz ! the flow
+ real(WP) :: velocity ! constant velocity of the flux
+ integer :: ierr ! mpi error code
+ integer :: i,j,k ! mesh indice
+ real(WP) :: T ! time
+ real(WP) :: T_end ! final time
+ real(WP) :: T_ite ! time corresponding to output
+ real(WP) :: dt ! time step
+ real(WP), dimension(:, :, :), allocatable :: good_scal ! analytic solution
+ real(WP), dimension(:, :, :), allocatable :: good_velo ! temp field
+ real(WP), dimension(:), allocatable :: pos_adim ! temp field
+ real(WP), dimension(3) :: translat ! to compute analytic solution
+ integer :: tag_rot ! tag for visualisation context
+ integer :: tag_sol ! tag for visualisation context
+
+
+ allocate(scal3D(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_scal(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vx(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vy(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(Vz(N_proc(1), N_proc(2), N_proc(3)))
+ allocate(good_velo(N_proc(1), N_proc(2), N_proc(3)))
+
+ init = '2D_rot'
+ success = .true.
+ ! Initialize output context
+ call vtkxml_init_all(2, nb_proc_dim, length, cart_rank, coord,'./adv_res/')
+
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order)
+ call vtkxml_init_field('turning', tag_rot)
+ call vtkxml_init_field('turn_sol', tag_sol)
+
+
+ ! Initialise the velocity
+ call scal_init(init, scal3D, good_scal)
+ period = 1
+ dt = 0.02
+ allocate(pos_adim(N_proc(1)))
+ pos_adim = 1
+ call velo_init(init, Vx, 1, pos_adim, good_velo)
+ call velo_init(init, Vy, 2, pos_adim, good_velo)
+ call velo_init(init, Vz, 3, pos_adim, good_velo)
+ call vtkxml_write(tag_rot, scal3D, 'turning')
+ call test_substatus('initialisation', success, cart_rank)
+
+ ! Advec it with a particular method
+ T = 0
+ T_end = 4*period
+ T_ite = 0
+ do while (T<=T_end - dt)
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ T = T + dt
+ if (T>T_ite) then
+ T_ite = T_ite + T_end/30
+ call test_substatus ('time', T, cart_rank)
+ call vtkxml_write(tag_rot, scal3D, 'turning')
+ end if
+ end do
+ if (T<T_end) then
+ dt = T_end - T
+ call advec_step(dt, Vx, Vy, Vz, scal3D)
+ end if
+ call vtkxml_write(tag_rot, scal3D, 'turning')
+ call vtkxml_write(tag_sol, good_scal)
+
+ call test_check_success(scal3D, good_scal, success, cart_rank)
+ call test_substatus('turning sphere', success, cart_rank)
+
+
+ ! --- Free memory ---
+ call vtkxml_finish()
+ deallocate(scal3D)
+ deallocate(good_scal)
+ deallocate(Vx)
+ deallocate(Vy)
+ deallocate(Vz)
+
+ success = .not.success
+
+end function test_advec_rot
+
+end module advec_aux
+
+!> @}
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_common.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_common.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e4c09026a4b47a610e399482ae9dd081498a5ace
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_common.f90
@@ -0,0 +1,892 @@
+!> @addtogroup part_test
+!! @{
+
+!------------------------------------------------------------------------------
+!
+! MODULE: test_part_common
+!
+! DESCRIPTION:
+!> This module provides tests to validate the particular solver. It is
+!! more precisly focused on testing the "common part" (advec_common) used for each
+!! directions.
+!!
+!! @author
+!! Jean-Baptiste Lagaert, LEGI
+!!
+!! @details
+!! This module is devoted to validate all the procedure from "advec_common". All the
+!! tests are unit tests: they return a logical value to check if the code version pass
+!! it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular
+!! solver
+!! This module provide the following test:
+!! - Validate the particular method, step by step
+!! - Test the procedure "AC_obtain_senders" from advec_common
+!! - Validate the redistribution the buffer during the remeshing
+!! - Validate the redistribution the buffer during the remeshing -
+!! debug version : only one processus contains non-zero field.
+!! - Validate the remeshing of untagged particles
+!! - Validate the velocity interpolation (the RK2 scheme use the
+!! velocity at midlle point to advec particles).
+!! - Validate how type (left or center) and tag are computing for a
+!! single line
+!! - Validate how type (left or center) and tag are computing for a
+!! group of line
+!!
+!
+!------------------------------------------------------------------------------
+
+module advec_aux_common
+
+ use string
+ use precision
+ implicit none
+
+
+
+ ! ===== Test for the particles solver =====
+ ! Public function
+ public :: test_part_AC_velo_determine_com
+ !public :: test_part_AC_bufferToScalar
+ !public :: test_part_AC_bufferToScalar_Deb
+ !public :: test_part_AC_interpol_velocity
+ public :: test_part_AC_type_and_block_O2_group
+
+
+
+
+contains
+
+
+!!> Particles method: validation of the procedure "AC_bufferToScalar".
+!!! @return success = test success (= false if the code pass the test)
+!!! @param[in] shift = global translation of indices (optional)
+!!! @details
+!!! Test the procedure "AC_obtain_senders" wich send local buffer use for remeshing
+!!! to the right processes. This procedure belong to "advec_common".
+!function test_part_AC_bufferToScalar(shift) result(success)
+!
+! ! Library
+! use mpi
+! ! Scale code
+! use advec
+! use advec_common ! Some porcedure common to advection along all directions
+! use advec_variables ! contains info about solver parameters and others.
+! use cart_topology
+! ! Test procdure
+! use test_common
+!
+! integer, intent(in), optional :: shift
+! logical :: success
+!
+! integer :: shift_bis ! global translation of indices
+! character(str_short) :: order ! order of the particles solver
+! integer :: j_min, j_max ! input argument of the tested procedure
+! real(WP), dimension(:), allocatable :: send_buffer ! the buffer to redistribute
+! real(WP), dimension(:), allocatable :: scal1D ! the scalar field
+! integer :: direction ! direction (2 if along Y, 3=along Z)
+! real(WP) :: good_scal ! theoritical value of scal1D
+! integer, dimension(2) :: ind_group ! indice of current group of lines
+! integer, dimension(2) :: rece_proc ! minimal and maximal gap between my coordinate and the one from which
+! ! I will receive data
+! integer :: proc_min ! smaller gap between me and the processes to where I send data
+! integer :: proc_max ! smaller gap between me and the processes to where I send data
+!
+! ! Some initialisation
+! success = .true.
+! ind_group = 1
+! if (present(shift)) then
+! shift_bis = shift
+! else
+! shift_bis = 0
+! end if
+! call test_substatus('shift', shift_bis, cart_rank)
+!
+! ! Initialize the particular solver
+! order = 'p_O2'
+! call advec_init(order, verbosity=.false.)
+!
+! do direction = 1, 3
+! if (nb_proc_dim(direction)>1) then
+! call test_substatus('direction', direction, cart_rank)
+! good_scal = modulo(coord(direction)-shift_bis, nb_proc_dim(direction))
+!
+! ! Test 1 - unrealistic case with no communication
+! ! Initialize the buffer to remesh
+! call AC_set_part_bound_size(0)
+! j_min = 1 + shift_bis*N_proc(direction)
+! j_max = N_proc(direction)*(shift_bis+1)
+! allocate (send_buffer(j_min:j_max))
+! allocate (scal1D(1:N_proc(direction)))
+! send_buffer = coord(direction)
+! scal1D = 0.0
+! ! Let's go !
+! ! Determine the communication needed : who will communicate whit who?
+! call AC_obtain_senders_line(j_min, j_max, direction, ind_group, proc_min, proc_max, rece_proc)
+! ! And then distribute buffer along the processus
+! call AC_bufferToScalar(direction, ind_group, j_min, j_max, proc_min, proc_max, rece_proc, send_buffer, scal1D)
+! ! Check the success
+! call test_check_success(scal1D, good_scal, success, cart_rank)
+! deallocate (send_buffer)
+! deallocate (scal1D)
+! call test_substatus('just me', success, cart_rank)
+!
+! ! I communicate with my two neighbors
+! call advec_init(order, verbosity=.false.)
+! j_min = shift_bis*N_proc(direction)
+! j_max = (1+shift_bis)*N_proc(direction) -1+2*bl_bound_size
+! allocate (send_buffer(j_min:j_max))
+! allocate (scal1D(1:N_proc(direction)))
+! send_buffer = coord(direction)
+! send_buffer(j_min) = modulo(coord(direction)-1, nb_proc_dim(direction))/2.0
+! send_buffer(j_min+1) = send_buffer(j_min+1)/2.
+! send_buffer(j_max) = modulo(coord(direction)+1, nb_proc_dim(direction))/2.0
+! send_buffer(j_max-1) = send_buffer(j_max-1)/2.
+! scal1D = 0.0
+! ! Determine the communication needed : who will communicate whit who?
+! call AC_obtain_senders_line(j_min, j_max, direction, ind_group, proc_min, proc_max, rece_proc)
+! ! And then distribute buffer along the processus
+! call AC_bufferToScalar(direction, ind_group, j_min, j_max, proc_min, proc_max, rece_proc, send_buffer, scal1D)
+! ! Check the success
+! call test_check_success(scal1D, good_scal, success, cart_rank)
+! deallocate (send_buffer)
+! deallocate (scal1D)
+! call test_substatus('me and my neighbors', success, cart_rank)
+! else
+! call test_substatus('only one proc along direction, no test', cart_rank)
+! end if
+! end do
+!
+! success = .not.success
+!
+!end function test_part_AC_bufferToScalar
+!
+!
+!
+!!> Particles method: validation of the procedure "AC_bufferToScalar"
+!!! @return success = test success (= false if the code pass the test)
+!!! @param[in] shift = global translation of indices (optional)
+!!! @param[in] rank = rank of the processus which will contains non-zero field.
+!!! @details
+!!! Debugging version : only one processus contains non zero field to remesh.
+!!! Each processus communicate with its two neibor. A shift could be add.
+!function test_part_AC_bufferToScalar_Deb(rank, shift) result(success)
+!
+! ! Library
+! use mpi
+! ! Scale code
+! use advec
+! use advec_common ! Some porcedure common to advection along all directions
+! use advec_variables ! contains info about solver parameters and others.
+! use cart_topology
+! ! Test procdure
+! use test_common
+!
+! integer, intent(in) :: rank
+! integer, intent(in), optional :: shift
+! logical :: success
+!
+! integer :: ierr ! mpi error code
+! integer :: shift_bis ! global translation of indices
+! character(str_short) :: order ! order of the particles solver
+! integer :: j_min, j_max ! input argument of the tested procedure
+! real(WP), dimension(:), allocatable :: send_buffer ! the buffer to redistribute
+! real(WP), dimension(:), allocatable :: scal1D ! the scalar field
+! real(WP), dimension(:), allocatable :: good_scal ! theoritical value of scal1D
+! integer :: direction ! direction (2 if along Y, 3=along Z)
+! integer, dimension(3) :: mycoord ! my coordonates in the mpi topology
+! integer :: rank_shift ! rank of processus of rank = rank+shift
+! integer, dimension(2) :: ind_group ! indice of current group of lines
+! integer, dimension(2) :: rece_proc ! minimal and maximal gap between my coordinate and the one from which
+! ! I will receive data
+! integer :: proc_min ! smaller gap between me and the processes to where I send data
+! integer :: proc_max ! smaller gap between me and the processes to where I send data
+!
+! ! Some initialisation
+! success = .true.
+! ind_group = 1
+! if (present(shift)) then
+! shift_bis = shift
+! else
+! shift_bis = 0
+! end if
+! call test_substatus('shift', shift_bis, cart_rank)
+! call test_substatus('rank tested', rank, cart_rank)
+!
+! ! Initialize the particular solver
+! order = 'p_O2'
+! call advec_init(order, verbosity=.false.)
+!
+! do direction = 1, 3
+! call test_substatus('direction', direction, cart_rank)
+! if (nb_proc_dim(direction)>1) then
+! ! Initialise the solver environnement and the field
+! call advec_init(order, verbosity=.false.)
+! j_min = shift_bis*N_proc(direction)
+! j_max = (1+shift_bis)*N_proc(direction) -1+2*bl_bound_size
+! allocate (send_buffer(j_min:j_max))
+! allocate (scal1D(1:N_proc(direction)))
+! send_buffer = 0
+! if (cart_rank == rank) then
+! send_buffer = 2
+! send_buffer(j_min) = 1
+! send_buffer(j_max) = 3
+! end if
+! scal1D = 0.0
+!
+! ! -- Compute the analytic solution --
+! allocate (good_scal(1:N_proc(direction)))
+! good_scal = 0.0
+! ! For the processus wich correspond to me after the shift
+! call mpi_cart_coords(cart_comm, rank, 3, mycoord, ierr)
+! mycoord(direction) = mycoord(direction) + shift_bis
+! call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+! if (cart_rank==rank_shift) good_scal = 2
+! ! For the next processus in the current direction
+! mycoord(direction) = mycoord(direction) + 1
+! call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+! if (cart_rank==rank_shift) good_scal(1) = 3
+! ! For the previous processus in the current direction
+! mycoord(direction) = mycoord(direction) -2
+! call mpi_cart_rank(cart_comm, mycoord, rank_shift, ierr)
+! if (cart_rank==rank_shift) good_scal(N_proc(direction)) = 1
+!
+! ! -- Compute the numerical solution --
+! ! Determine the communication needed : who will communicate whit who?
+! call AC_obtain_senders_line(j_min, j_max, direction, ind_group, proc_min, proc_max, rece_proc)
+! ! And then distribute buffer along the processus
+! call AC_bufferToScalar(direction, ind_group, j_min, j_max, proc_min, proc_max, rece_proc, send_buffer, scal1D)
+! ! Check the success
+! call test_check_success(scal1D, good_scal, success, cart_rank)
+! deallocate (send_buffer)
+! deallocate (scal1D)
+! deallocate (good_scal)
+! call test_substatus('me and my neighbors', success, cart_rank)
+! else
+! call test_substatus('only one proc along direction, no test', cart_rank)
+! end if
+! end do
+!
+! success = .not.success
+!
+!
+!end function test_part_AC_bufferToScalar_Deb
+
+
+!> Particles method: validation of the procedure "AC_velocity_determine_communication" wich determine
+!! who will comunicate with who during the remeshing
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] shift = global translation of indices (optional)
+function test_part_AC_velo_determine_com(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scale code
+ use advec
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ use cart_topology
+ ! Test procdure
+ use test_common
+
+ integer, intent(in), optional :: shift
+ logical :: success
+ ! Be aware : during this function, success = true if everything is right, but we return not success = error
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+ integer :: ierr ! mpi error code
+ integer , dimension(5,5) :: rece_ind_min ! minimal indice of mesh involved in remeshing particles (of my local subdomains)
+ integer , dimension(5,5) :: rece_ind_max ! maximal indice of mesh involved in remeshing particles (of my local subdomains)
+ integer, dimension(5,5,2) :: rece_gap ! distance between me and processus wich send me information
+ integer, dimension(2 , 2) :: send_gap ! distance between me and processus to wich I send information
+ integer, dimension(2) :: rece_gap_abs ! min (resp max) value of rece_gap(:,:,i) with i=1 (resp 2)
+ integer, dimension(:), allocatable :: rece_rank ! rank of processus from which I receive data
+ integer, dimension(2 , 2) :: send_theoric ! theoritical value of send_gap
+ integer, dimension(2) :: ind_group ! indice of current group of lines
+ integer :: direction ! current direction (alonG X, Y or Z)
+ integer, dimension(:,:), allocatable :: cartography ! cartography(proc_gap) contains the set of the lines indice in the block for wich the
+ ! current processus requiers data from proc_gap and for each of these lines the range
+ ! of mesh points from where it requiers the velocity values.
+ integer, dimension(:,:), allocatable :: carto_th ! theoritical value of cartography
+ integer :: max_size
+ integer :: proc_gap ! gap between two different mpi processus
+ integer, dimension(2) :: gs ! group size
+
+
+ ! Some initialisation
+ success = .true.
+ ind_group = 1
+ gs = (/5,5/)
+ direction = 3
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+ call test_substatus('shift', shift_bis, cart_rank)
+
+ ! Initialize the particular solver
+ order = 'p_O2'
+ call advec_init(order, verbosity=.false.)
+ call test_substatus('initialisation solveur', success, cart_rank)
+
+ ! ===== Each line of the group is initialized considering it second indice =====
+ ! -- First line communcate just with myself (ie it host processus) --
+ ! Init the indice range for each lines.
+ rece_ind_min(:,1) = 1 + shift_bis*N_proc(direction)
+ rece_ind_max(:,1) = N_proc(direction)*(shift_bis+1)
+ ! -- Second line communicate with me and the previous processus --
+ rece_ind_min(:,2) = shift_bis*N_proc(direction)
+ rece_ind_max(:,2) = (1+shift_bis)*N_proc(direction)
+ ! -- Third line communicate with me and my two neighbors --
+ rece_ind_min(:,3) = shift_bis*N_proc(direction)
+ rece_ind_max(:,3) = (1+shift_bis)*N_proc(direction) + 1
+ ! -- Fourth line communicate with me and the next processus --
+ rece_ind_min(:,4) = shift_bis*N_proc(direction) + 1
+ rece_ind_max(:,4) = (1+shift_bis)*N_proc(direction) + 1
+ ! -- And for the fith line it depend of it firts indice inside the group --
+ rece_ind_min(:,5) = 1 + shift_bis*N_proc(direction)
+ rece_ind_min(3,5) = shift_bis*N_proc(direction)
+ rece_ind_max(:,5) = (1+shift_bis)*N_proc(direction) + 1
+ rece_ind_max(2,5) = (1+shift_bis)*N_proc(direction)
+
+ ! Compute the associated processus
+ rece_gap(:,:,1) = floor(real(rece_ind_min-1)/N_proc(direction))
+ rece_gap(:,:,2) = floor(real(rece_ind_max-1)/N_proc(direction))
+ rece_gap_abs(1) = minval(rece_gap(:,:,1))
+ rece_gap_abs(2) = maxval(rece_gap(:,:,2))
+ allocate(rece_rank(rece_gap_abs(1):rece_gap_abs(2)))
+ max_size = 2 + gs(2)*(2+3*gs(1))
+ allocate(cartography(max_size,rece_gap_abs(1):rece_gap_abs(2)))
+
+
+ ! -- And launch the test --
+ cartography = -1
+ call AC_velocity_determine_communication(direction, ind_group, gs, send_gap, &
+ & rece_gap, rece_gap_abs, rece_rank, cartography)
+
+ ! -- Check result --
+ ! send_gap
+ send_theoric(1,:) = (/-1-shift_bis,1-shift_bis/)
+ send_theoric(2,:) = 25
+ call test_check_success(send_gap, send_theoric, success, cart_rank)
+ call test_substatus('send_gap', success, cart_rank)
+ ! cartography
+ allocate(carto_th(max_size, rece_gap_abs(1):rece_gap_abs(2)))
+ carto_th = -1
+ if (rece_rank(-1+shift_bis) /= D_rank(direction)) then
+ carto_th(1:13,-1+shift_bis)= (/0,13,0,2,2,0,2,1,5,1,5,3,3/)
+ else
+ carto_th(1:7,-1+shift_bis)= (/0,7,0,0,0,0,0/)
+ end if
+ if (rece_rank(shift_bis) /= D_rank(direction)) then
+ carto_th(1:17,shift_bis)= (/0,17,2,2,2,2,2,1,5,1,5,1,5,1,5,1,5/)
+ else
+ carto_th(1:7,shift_bis)= (/0,7,0,0,0,0,0/)
+ end if
+ if (rece_rank(1+shift_bis) /= D_rank(direction)) then
+ carto_th(1:15,1+shift_bis)= (/0,15,0,0,2,2,4,1,5,1,5,1,1,3,5/)
+ else
+ carto_th(1:7,1+shift_bis)= (/0,7,0,0,0,0,0/)
+ end if
+ call test_check_success(cartography, carto_th, success, cart_rank)
+ call test_substatus('cartography', success, cart_rank)
+
+! ! -- For the fourth: Contraction / extention --
+! if (modulo(nb_proc_dim(direction),2)==0) then
+! if (modulo(D_rank(direction),2)== 0) then
+! ! Contraction
+! j_min = 1 + shift_bis*N_proc(direction)
+! j_max = (1+shift_bis)*N_proc(direction)
+! send_begin = 0
+! send_end = 0
+! else
+! ! Dilatation
+! j_min = +1 - 2*bl_bound_size + shift_bis*N_proc(direction)
+! j_max = (1+shift_bis)*N_proc(direction) + 2*bl_bound_size
+! send_begin = -1
+! send_end = 1
+! end if
+
+ deallocate(rece_rank)
+ deallocate(cartography)
+ deallocate(carto_th)
+
+ success = .not.success
+
+end function test_part_AC_velo_determine_com
+
+
+!> Particles method: validation of the velocity interpolation
+!! @return success = test success (= false if the code pass the test)
+!! @param[in] direction = 1 for along X, 2 for along Y, 3 for along Z
+!! @param[in] shift = global translation of indice
+function test_part_AC_velo_compute_group(direction, shift) result(success)
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ use advec_common
+ ! Test procedures
+ use advec_aux_init
+ use test_common
+
+ logical :: success
+ integer, intent(in) :: direction, shift
+
+ integer :: ind,ind1,ind2! indices
+ integer :: nn, clock ! to generate random number
+ integer, dimension(:), allocatable :: seed ! to generate random number
+ real(WP), dimension(N_proc(direction), 5, 5) :: p_pos ! location where the velocity is interpolated
+ real(WP), dimension(N_proc(direction)) :: r ! random numbers to initialise p_pos
+ real(WP), dimension(N_proc(direction),5,5) :: velo ! velocity field
+ real(WP), dimension(N_proc(direction),5,5) :: good_velo ! analytic interpolation of velocity field in particles position
+ real(WP) :: dt ! time step
+ integer :: T ! for solver iteration
+ integer, dimension(2) :: gs ! group size
+
+ ! Initialisation
+ success = .true.
+ call test_substatus('test velocity interpolation', cart_rank)
+ call test_substatus('shift', shift, cart_rank)
+ ! To generate random number
+ call RANDOM_SEED(size = nn)
+ allocate(seed(nn))
+ call SYSTEM_CLOCK(COUNT=clock)
+ seed = clock + 37 * (/ (ind - 1, ind = 1, nn) /)
+ call RANDOM_SEED(PUT = seed)
+ deallocate(seed)
+ ! Position where the velocity will be interpolated
+ CALL RANDOM_NUMBER(r)
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,:) = (ind+shift)
+ end do
+ gs = group_size(direction,:)
+ call test_check_success((/5,5/),gs, success, cart_rank)
+ call test_substatus('group is 5', success, cart_rank)
+ if (success) then
+
+ ! ===== Init particle positions =====
+ ! -- First column : particle are inside current and previous processes --
+ p_pos(:,1,1) = p_pos(:,1,1) - 3 + r*d_sc(direction)
+ p_pos(:,2,1) = p_pos(:,2,1) - 3
+ p_pos(:,3,1) = p_pos(:,3,1) - 2 + r*d_sc(direction)
+ p_pos(:,4,1) = p_pos(:,4,1) - 2
+ p_pos(:,5,1) = p_pos(:,5,1) - 1 + r*d_sc(direction)
+ ! -- Second and third column : they are on the current processus and my two neighbors --
+ p_pos(:,:,2) = p_pos(:,:,1) + 1
+ p_pos(:,:,3) = p_pos(:,:,1) + 2
+ ! -- Fourth column: paritcles are on the current and th next processes --
+ p_pos(:,:,4) = p_pos(:,:,1) + 3
+
+
+ ! ===== First test: constant velocity =====
+ do ind2 = 1, 5
+ do ind1 = 1, 5
+ call particle_velo_init('constant', velo(:,ind1,ind2), direction, p_pos(:,ind1,ind2), good_velo(:,ind1,ind2))
+ end do
+ end do
+ dt = 0.0
+ call AC_particle_velocity(dt, direction, gs, (/1,1/), p_pos, velo)
+ ! Check result
+ call test_check_success(velo, good_velo, success, cart_rank)
+ call test_substatus('constant velocity', success, cart_rank)
+
+ ! ===== Second test: unconstant velocity =====
+ do ind2 = 1, 5
+ do ind1 = 1, 5
+ call particle_velo_init('translation_field', velo(:,ind1,ind2), direction, &
+ & p_pos(:,ind1,ind2), good_velo(:,ind1,ind2))
+ end do
+ end do
+ call AC_particle_velocity(dt, direction, gs, (/1,1/), p_pos, velo)
+ ! Check result
+ call test_check_success(velo, good_velo, success, cart_rank)
+ call test_substatus('unconstant velocity', success, cart_rank)
+ end if
+
+ ! Return not success
+ success = .not. success
+
+end function test_part_AC_velo_compute_group
+
+
+!> Particle method: validation of particle tag and block type determination for
+!! a group of line
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_AC_type_and_block_O2_group() result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ use cart_topology
+ ! Test procedures
+ use test_common
+
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+
+ logical, dimension(:,:,:), allocatable :: bl_type ! correct (analytic) type of block
+ logical, dimension(:,:,:), allocatable :: bl_tag ! correct (analytic) tag of block
+ logical, dimension(:,:,:), allocatable :: good_type ! correct (analytic) type of block
+ logical, dimension(:,:,:), allocatable :: good_tag ! correct (analytic) tag of block
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ real(WP) :: dt, cfl ! time step and CFL number
+ real(WP), dimension(:,:,:), allocatable :: p_V ! particle velocity (used to tag particles)
+ integer :: ind, ind2 ! indice of the current particle
+ integer :: ind_bl ! indice of the current block
+ real(WP) :: lambda_min ! minimum courant number on a block
+ integer :: ind_tag_bl ! indice of the first tagged block in the test
+ integer :: ind_tag_p ! indice of particle corresponding to the velocity
+ ! variation wich induce a tag of the block ind_tag_bl
+ integer :: ind_tag_bl2 ! indice of the second tagged block in the test
+ integer :: ind_tag_p2 ! indice of particle wich induce a tag of the block ind_tag_bl2
+
+
+ ! Initialisation of context (solver, ...)
+ success = .true.
+ order ='p_O2'
+ call set_group_size(5)
+ call advec_init(order, verbosity=.false.)
+ direction = 3
+
+ ! Allocation
+ allocate(bl_type(bl_nb(direction)+1,group_size(direction,1),group_size(direction,2)))
+ allocate(good_type(bl_nb(direction)+1,group_size(direction,1),group_size(direction,2)))
+ allocate(bl_tag(bl_nb(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(good_tag(bl_nb(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(p_V(N_proc(direction),group_size(direction,1),group_size(direction,2)))
+
+ ! Initialize of the different parameter and field
+ dt = 1
+ cfl = dt/d_sc(direction)
+ p_V = 0
+
+ ! Test case = nothing on line of indice different from (2,3)
+ ! On that line, first part of block are left one, and second part are center.
+ ! Due to periodic condition, there is also 2 tag, one for each type switch
+ ! (left => center, and center => left).
+ ! Update dt in order to create "chock" without broke the stability condition
+ dt = 0.8*d_sc(direction)/sqrt(2*1.2*bl_size)
+ cfl = dt/d_sc(direction)
+ good_type = .false.
+ good_tag = .false.
+ ind_tag_bl = (nb_proc_dim(direction)*bl_nb(direction)/3) - (bl_nb(direction)*coord(direction))
+ ind_tag_p = (ind_tag_bl-1)*bl_size + bl_size/2 + 1
+ ind_tag_p2 = floor((0.3/0.8)*(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p) + ind_tag_p)
+ ind_tag_p2 = ind_tag_p2 + 1
+ ind_tag_bl2 = (ind_tag_p2 - 1 - bl_size/2)/bl_size + 1
+ if (modulo(ind_tag_p2-1-bl_size/2, bl_size)==0) ind_tag_bl2 = ind_tag_bl2 -1
+ if (ind_tag_bl <=bl_nb(direction)) then
+ if (ind_tag_bl>=1) then
+ ! Tag the right block transition
+ good_tag(ind_tag_bl, 2, 3) = .true.
+ else
+ ! Change the velocity for the first half block
+ lambda_min = max(0,shift_bis) + 10
+ do ind = 1, bl_size/2
+ p_V(ind, 2, 3) = 0.8*(1.0-float(ind-ind_tag_p) &
+ & /(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind+1<ind_tag_p2) good_type(1, 2, 3) = .true.
+ end if
+ ! Update velocity and block type
+ do ind_bl = max(2, ind_tag_bl+1), bl_nb(direction)
+ lambda_min = max(0,shift_bis) + 10
+ do ind = 1, bl_size
+ ind2 = ind+((ind_bl-2)*bl_size)+bl_size/2 ! the first block is only a half block
+ p_V(ind2, 2, 3) = 0.8*(1.-float(ind2-ind_tag_p) &
+ &/(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind2+1<ind_tag_p2) good_type(ind_bl, 2, 3) = .true.
+ end do
+ ! For the last half block
+ lambda_min = max(0,shift_bis) + 10
+ ind_bl = bl_nb(direction) + 1
+ do ind = 1, bl_size/2
+ ind2 = ind+((ind_bl-2)*bl_size)+bl_size/2 ! the first block is only a half block
+ p_V(ind2, 2 , 3) = 0.8*(1.-float(ind2-ind_tag_p) &
+ & /(N(direction)-N_proc(direction)*coord(direction)-ind_tag_p))/cfl
+ end do
+ if (ind2+bl_size/2+1<ind_tag_p2) good_type(ind_bl, 2, 3) = .true.
+ end if
+ if ((ind_tag_bl2 <= bl_nb(direction)).and.(ind_tag_bl2>0)) good_tag(ind_tag_bl2, 2, 3) = .true.
+ call AC_type_and_block(dt, direction, group_size(direction,:), (/1,1/), p_V, bl_type, bl_tag)
+
+
+ call test_check_success(bl_tag, good_tag, success, cart_rank)
+ call test_substatus('test 3 - two tag ', success, cart_rank)
+ call test_check_success(bl_type, good_type, success, cart_rank)
+ call test_substatus('test 3 - center at first, then left', success, cart_rank)
+
+
+ ! Deallocation
+ deallocate(bl_type)
+ deallocate(good_type)
+ deallocate(bl_tag)
+ deallocate(good_tag)
+ deallocate(p_V)
+
+ success = .not. success
+
+end function test_part_AC_type_and_block_O2_group
+
+
+! ============================================================
+! ========== Test about remeshing ==========
+! ============================================================
+
+!> Particle method: validation of computation of remeshing range for a group of line
+!! @param[in] shift = global translation of indice
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_AC_remesh_range() result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ use cart_topology
+ ! Test procedures
+ use test_common
+ use advec_aux_init
+
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+
+ logical, dimension(:,:,:), allocatable :: bl_type ! type of block
+ logical, dimension(:,:,:), allocatable :: bl_tag ! tag of block
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ real(WP), dimension(:,:,:), allocatable :: p_pos_adim ! particle position
+ integer, dimension(:,:), allocatable :: send_min ! first mesh where particles are remeshed
+ integer, dimension(:,:), allocatable :: good_send_min! theoritical first mesh where particles are remeshed
+ integer, dimension(:,:), allocatable :: send_max ! last mesh where particles are remeshed
+ integer, dimension(:,:), allocatable :: good_send_max! theoritical last mesh where particles are remeshed
+ integer, dimension(:,:,:), allocatable :: send_gap ! distance between me and processus wich send me information
+ integer, dimension(2) :: send_gap_abs ! min (resp max) value of rece_gap(:,:,i) with i=1 (resp 2)
+ integer, dimension(2) :: gs ! group size
+ integer, dimension(2) :: ind_group ! group indice
+
+
+ ! Initialisation of context (solver, ...)
+ success = .true.
+ direction = 2
+ shift_bis = 0.0
+ ind_group = (/1,1/)
+ call set_group_size(5)
+ gs = group_size(direction,:)
+
+ ! Allocation
+ allocate(bl_type(bl_nb(direction)+1,group_size(direction,1),group_size(direction,2)))
+ allocate(bl_tag(bl_nb(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(p_pos_adim(N_proc(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(send_min(group_size(direction,1),group_size(direction,2)))
+ allocate(send_max(group_size(direction,1),group_size(direction,2)))
+ allocate(good_send_min(group_size(direction,1),group_size(direction,2)))
+ allocate(good_send_max(group_size(direction,1),group_size(direction,2)))
+ allocate(send_gap(group_size(direction,1),group_size(direction,2),2))
+
+ ! ----- Initialisation -----
+ bl_type = .true.
+ bl_tag = .false.
+ call pos_gp_init(direction, gs, shift_bis, p_pos_adim, bl_type)
+
+ ! ----- Lambda 2 corrected -----
+ order ='p_O2'
+ ! Init solver
+ call advec_init(order, verbosity=.false.)
+ ! Test procedure
+ call AC_remesh_range(bl_type, p_pos_adim, direction, send_min, send_max, send_gap, send_gap_abs)
+ ! Compute theoric value
+ where (bl_type(1,:,:))
+ ! First particle is a centered one
+ send_min = nint(p_pos_adim(1,:,:))-1
+ elsewhere
+ ! First particle is a left one
+ send_min = floor(p_pos_adim(1,:,:))-1
+ end where
+ where (bl_type(N_proc(direction)/bl_size +1,:,:))
+ ! Last particle is a centered one
+ send_max = nint(p_pos_adim(N_proc(direction),:,:))+1
+ elsewhere
+ ! Last particle is a left one
+ send_max = floor(p_pos_adim(N_proc(direction),:,:))+1
+ end where
+ ! Check results
+ call test_check_success(send_min, good_send_min, success, cart_rank)
+ call test_check_success(send_max, good_send_max, success, cart_rank)
+ call test_substatus('remesh range - order 2 ', success, cart_rank)
+
+ ! ----- Lambda 4 corrected -----
+ order ='p_O4'
+ ! Init solver
+ call advec_init(order, verbosity=.false.)
+ ! Test procedure
+ call AC_remesh_range(bl_type, p_pos_adim, direction, send_min, send_max, send_gap, send_gap_abs)
+ ! Compute theoric value
+ where (bl_type(1,:,:))
+ ! First particle is a centered one
+ send_min = nint(p_pos_adim(1,:,:))-2
+ elsewhere
+ ! First particle is a left one
+ send_min = floor(p_pos_adim(1,:,:))-2
+ end where
+ where (bl_type(N_proc(direction)/bl_size +1,:,:))
+ ! Last particle is a centered one
+ send_max = nint(p_pos_adim(N_proc(direction),:,:))+2
+ elsewhere
+ ! Last particle is a left one
+ send_max = floor(p_pos_adim(N_proc(direction),:,:))+2
+ end where
+ ! Check results
+ call test_check_success(send_min, good_send_min, success, cart_rank)
+ call test_check_success(send_max, good_send_max, success, cart_rank)
+ call test_substatus('remesh range - order 4 ', success, cart_rank)
+
+ ! ----- M'6 -----
+ order ='p_O2'
+ ! Init solver
+ call advec_init(order, verbosity=.false.)
+ ! Test procedure
+ call AC_remesh_range(bl_type, p_pos_adim, direction, send_min, send_max, send_gap, send_gap_abs)
+ ! Compute theoric value
+ send_min = nint(p_pos_adim(1,:,:))-2
+ send_max = floor(p_pos_adim(N_proc(direction),:,:))+3
+ ! Check results
+ call test_check_success(send_min, good_send_min, success, cart_rank)
+ call test_check_success(send_max, good_send_max, success, cart_rank)
+ call test_substatus('remesh range - Mprime 6 ', success, cart_rank)
+! call AC_remesh_determine_communication(direction, gs, ind_group, rece_gap, send_gap, send_gap_abs, send_rank, cartography)
+
+
+ ! Free memory
+ deallocate(bl_type)
+ deallocate(bl_tag)
+ deallocate(p_pos_adim)
+ deallocate(send_min)
+ deallocate(send_max)
+ deallocate(good_send_min)
+ deallocate(good_send_max)
+ deallocate(send_gap)
+
+ success = .not. success
+
+end function test_part_AC_remesh_range
+
+
+!> Particle method: validation of computation of remeshing range for a group of line
+!! @return error = test error (= false if the code pass the test) (= not success)
+function test_part_AC_remesh_determine_communication(shift) result(success)
+
+ ! Library
+ use mpi
+ ! Scales code
+ use advec
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ use cart_topology
+ ! Test procedures
+ use test_common
+ use advec_aux_init
+
+ integer, intent(in), optional :: shift
+ logical :: success
+
+ integer :: shift_bis ! global translation of indices
+ character(str_short) :: order ! order of the particles solver
+
+ logical, dimension(:,:,:), allocatable :: bl_type ! type of block
+ logical, dimension(:,:,:), allocatable :: bl_tag ! tag of block
+ integer :: direction ! direction (2 if along Y, 3=along Z)
+ real(WP), dimension(:,:,:), allocatable :: p_pos_adim ! particle position
+ integer, dimension(:,:), allocatable :: send_min ! first mesh where particles are remeshed
+ integer, dimension(:,:), allocatable :: send_max ! last mesh where particles are remeshed
+ integer, dimension(:,:,:), allocatable :: send_gap ! distance between me and processus wich send me information
+ integer, dimension(2) :: send_gap_abs ! min (resp max) value of rece_gap(:,:,i) with i=1 (resp 2)
+ integer, dimension(2 , 2) :: rece_gap ! distance between me and processus to wich I send information
+ integer, dimension(2) :: gs ! group size
+ integer, dimension(2) :: ind_group ! group indice
+ integer :: max_size ! maximal size of cartography(:,proc_gap)
+ integer, dimension(:,:), allocatable :: cartography ! cartography(proc_gap) contains the set of the lines indice in the block to wich the
+ ! current processus will send data during remeshing and for each of these lines the range
+ ! of mesh points from where it requiers the velocity values.
+ integer, dimension(:), allocatable :: send_rank ! rank of processus to wich I send information
+
+
+ ! Initialisation of context (solver, ...)
+ success = .true.
+ direction = 2
+ shift_bis = 0.0
+ ind_group = (/1,1/)
+ call set_group_size(5)
+ gs = group_size(direction,:)
+ if (present(shift)) then
+ shift_bis = shift
+ else
+ shift_bis = 0
+ end if
+
+
+ ! Allocation
+ allocate(bl_type(bl_nb(direction)+1,group_size(direction,1),group_size(direction,2)))
+ allocate(bl_tag(bl_nb(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(p_pos_adim(N_proc(direction),group_size(direction,1),group_size(direction,2)))
+ allocate(send_min(group_size(direction,1),group_size(direction,2)))
+ allocate(send_max(group_size(direction,1),group_size(direction,2)))
+ allocate(send_gap(group_size(direction,1),group_size(direction,2),2))
+
+ ! ----- Initialisation -----
+ bl_type = .true.
+ bl_tag = .false.
+ call pos_gp_init(direction, gs, shift_bis, p_pos_adim, bl_type)
+
+ ! ===== Test method =====
+ ! -- Init solver --
+ order ='p_O2'
+ call advec_init(order, verbosity=.false.)
+ ! -- Compute range --
+ call AC_remesh_range(bl_type, p_pos_adim, direction, send_min, send_max, send_gap, send_gap_abs)
+ ! -- Allocation --
+ max_size = 2 + gs(2)*(2+3*gs(1))
+ allocate(cartography(max_size,send_gap_abs(1):send_gap_abs(2)))
+ allocate(send_rank(send_gap_abs(1):send_gap_abs(2)))
+ ! -- Test the target procedure: determine which processes communicate together --
+ call AC_remesh_determine_communication(direction, gs, ind_group, rece_gap, send_gap, send_gap_abs, send_rank, cartography)
+
+ ! -- Compute theoritical results
+
+ ! -- Check results --
+ !call test_check_success(send_min, good_send_min, success, cart_rank)
+ !call test_check_success(send_max, good_send_max, success, cart_rank)
+ !call test_substatus('remesh range - order 2 ', success, cart_rank)
+
+
+ ! -- Free memory --
+ deallocate(bl_type)
+ deallocate(bl_tag)
+ deallocate(p_pos_adim)
+ deallocate(send_min)
+ deallocate(send_max)
+ deallocate(send_gap)
+ deallocate(cartography)
+ deallocate(send_rank)
+
+ success = .not. success
+
+end function test_part_AC_remesh_determine_communication
+
+end module advec_aux_common
+!> @}
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_init.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_init.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9747a839c4dbcdcada15ce65aef9b87ca059e406
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_aux_init.f90
@@ -0,0 +1,529 @@
+!> @addtogroup part_test
+!! @{
+
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection_init
+!
+! DESCRIPTION:
+!> Initialisation procedure for advection test (and solver based on particle method).
+!!
+!! @details
+!! This module provide different initialisation setup in order to test the transport solver.
+!!
+!! The following initialisation are included :
+!! 1 -> Constant field for both scalar and velocity
+!! 2 -> 2D-rotation of a sphere
+!! 3 -> scalar(i,j,k) = i/Nx + 10* j/Ny + 100*k/Nz with periodic boundary condition
+!! 4 -> velocity(i,j,k) = i/Nx + 10* j/Ny + 100*k/Nz with periodic boundary condition
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module advec_aux_init
+
+ use string
+ use precision
+ implicit none
+
+ ! ===== Initialisation for advection test =====
+ ! Public function
+ public :: velo_init
+ public :: particle_velo_init
+ public :: scal_init
+ public :: scal_velo_init_part
+ ! Private function
+ private :: compute_velo_tag
+
+ ! ===== Setup parameter =====
+ ! Public variables
+ !> Period for rotation cases
+ real(WP), public :: period = 1
+ ! Private variable
+ !> Pi value
+ real(WP), parameter :: M_PI = ACOS(-1.0)
+
+
+
+
+contains
+
+!> Initialisation of the scalar field for the different tests.
+!! @param[in] init = parameter to initialise the scalar fied to a constant one or to a sphere shape
+!! @param[in] translat = optional argument, translat the field, in order to obtain analytic solution for non zero velocity in test case
+!! "translation field"
+!! @param[out] scalar = scalar field
+!! @param[out] good_scal = analytic solution
+subroutine scal_init(init, scalar, good_scal, translat)
+
+ use test_common
+ use cart_topology
+
+ character(len=*), intent(in) :: init
+ real(WP), dimension(:,:,:), intent(out) :: scalar
+ real(WP), dimension(:,:,:), intent(out) :: good_scal
+ real(WP), dimension(3), intent(in), optional :: translat
+
+ real(WP) :: rr, rx, ry, rz, rayon
+ real(WP) :: dist
+ integer :: i, j, k
+
+
+ select case(init)
+ case('constant')
+ call test_substatus('constant scal', cart_rank)
+ scalar = 1.
+ good_scal = 1.
+ case('2D_rot')
+ call test_substatus('uncentred sphere', cart_rank)
+ scalar = 0.
+ rayon = (minval(N*d_sc)/10.0)**2
+ do k = 1, N_proc(3)
+ rz = (d_sc(3)*(k + coord(3)*N_proc(3) - 3.0*N(3)/5.0))**2
+ do j = 1, N_proc(2)
+ ry = (d_sc(2)*(j + coord(2)*N_proc(2)- 3.0*N(2)/5.0))**2
+ do i = 1, N_proc(1)
+ rx = (d_sc(1)*(i - 3.0*N(1)/5.0))**2
+ rr = rx + ry + rz
+ if (rr < rayon) scalar(i,j,k) = (1 - rr/rayon)**4
+ end do
+ end do
+ end do
+ good_scal = scalar
+ case('translation_field')
+ call test_substatus('translation field', cart_rank)
+ if (present(translat)) then
+ call test_substatus('translation on X', translat(1), cart_rank)
+ call test_substatus('translation on Y', translat(2), cart_rank)
+ call test_substatus('translation on Z', translat(3), cart_rank)
+ else
+ call test_substatus('velocity = zero ', cart_rank)
+ end if
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ dist = (float(i-1+coord(1)*N_proc(1))/N(1))
+ scalar(i,j,k) = cos((dist-0.5)*2*M_PI)
+ dist = (float(j-1+coord(2)*N_proc(2))/N(2))
+ scalar(i,j,k) = scalar(i,j,k)*cos((dist-0.5)*2*M_PI)
+ dist = (float(k-1+coord(3)*N_proc(3))/N(3))
+ scalar(i,j,k) = scalar(i,j,k)*cos((dist-0.5)*2*M_PI)
+ if (present(translat)) then
+ ! Only periodic condition
+ dist = (i+translat(1)-1+coord(1)*N_proc(1))*d_sc(1) ! distance au bord x = 0
+ dist = modulo(dist, length(1)) ! on utilise la periodicite
+ ! In other case, as the velocity is a linear function of the position, the analytic velocity
+ ! is the same that the interpolate one
+ good_scal(i,j,k) = cos((dist-0.5)*2*M_PI)
+ dist = (j+translat(2)-1+coord(2)*N_proc(2))*d_sc(2)
+ dist = modulo(dist, length(2))
+ good_scal(i,j,k) = good_scal(i,j,k) * cos((dist-0.5)*2*M_PI)
+ dist = (k+translat(3)-1+coord(3)*N_proc(3))*d_sc(3)
+ dist = modulo(dist, length(3))
+ good_scal(i,j,k) = good_scal(i,j,k) * cos((dist-0.5)*2*M_PI)
+ else
+ good_scal(i,j,k) = scalar(i,j,k)
+ end if
+ end do
+ end do
+ end do
+ case default
+ scalar = 1.
+ good_scal = 1.
+ end select
+
+end subroutine scal_init
+
+
+
+!> Initialisation of the velocity field to test its interpolation
+!! @param[in] init = parameter to initialise the scalar fied to a constant one or to a sphere shape
+!! @param[out] velo = velocity field along one direction
+!! @param[in] direction = current direction (along X,Y or Z-axis)
+!! @param[in] p_pos_adim = adimensionned particles postion (location where the velocity will be interpolated)
+!! @param[in,out] good_velo = analytic interpolation of the velocity field (on location p_pos)
+subroutine velo_init(init, velo, direction, p_pos_adim, good_velo)
+
+ use test_common
+ use cart_topology
+
+ character(len=*), intent(in) :: init
+ real(WP), dimension(:,:,:), intent(inout) :: velo
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ integer, intent(in) :: direction
+ real(WP), dimension(:,:,:), intent(inout) :: good_velo
+
+ real(WP) :: dist ! distance from original position for translation case
+ integer :: i, j, k ! mesh indices
+ integer :: ierr ! mpi error code
+
+
+ select case(init)
+ case('constant')
+ velo = 1.
+ good_velo = 1.
+ case('2D_rot')
+ select case(direction)
+ case(1)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=(2*M_PI/period)*(length(2)/2.0-((j+coord(2)*N_proc(2))*d_sc(2)))
+ good_velo(i,j,k)=(2*M_PI/period)*(length(2)/2.0-((j+coord(2)*N_proc(2))*d_sc(2)))
+ end do
+ end do
+ end do
+ case(2)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=(2*M_PI/period)*(((i+coord(1)*N_proc(1))*d_sc(1))-length(1)/2.0)
+ good_velo(i,j,k)=(2*M_PI/period)*(((i+coord(1)*N_proc(1))*d_sc(1))-length(1)/2.0)
+ end do
+ end do
+ end do
+ case(3)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k)=0
+ good_velo(i,j,k)=0
+ end do
+ end do
+ end do
+ case default
+ call test_substatus(' XXX error : wrong direction =', direction, cart_rank)
+ stop
+ end select
+ case('translation_field')
+ select case(direction)
+ case(1)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(1) .eqv. .true.) then
+ dist = (p_pos_adim(i)-1+coord(1)*N_proc(1))*d_sc(1) ! distance au bord x = 0
+ dist = modulo(dist, length(1)) ! on utilise la periodicite
+ ! If dist belong to (length - dx, length) then with have to interpolate
+ ! the velocity between postion (length-dx) and 0 (due to periodicity boundary condition)
+ if (dist>length(1)-d_sc(1)) dist = (length(1)-dist)*(length(1)-d_sc(1))/d_sc(1)
+ ! In other case, as the velocity is a linear function of the position, the analytic velocity
+ ! is the same that the interpolate one
+ good_velo(i,j,k) = dist/length(1) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ else
+ call test_substatus(' boundary along X condition not implemented ', cart_rank)
+ end if
+ end do
+ end do
+ end do
+ case(2)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(2) .eqv. .true.) then
+ dist = (p_pos_adim(j)-1+coord(2)*N_proc(2))*d_sc(2)
+ dist = modulo(dist, length(2))
+ ! See direction 1 for explaination
+ if (dist>length(2)-d_sc(2)) dist = (length(2)-dist)*(length(2)-d_sc(2))/d_sc(2)
+ good_velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(dist)/length(2) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ else
+ call test_substatus(' boundary along X condition not implemented ', cart_rank)
+ end if
+ end do
+ end do
+ end do
+ case(3)
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*(float(k-1+coord(3)*N_proc(3))/N(3))
+ if (periods(3) .eqv. .true.) then
+ dist = (p_pos_adim(k)-1+coord(3)*N_proc(3))*d_sc(3)
+ dist = modulo(dist, length(3))
+ ! See direction 1 for explaination
+ if (dist>length(3)-d_sc(3)) dist = (length(3)-dist)*(length(3)-d_sc(3))/d_sc(3)
+ good_velo(i,j,k) = (float(i-1)/N(1)) &
+ & + 10*(float(j-1+coord(2)*N_proc(2))/N(2)) &
+ & + 100*dist/length(3)
+ else
+ call test_substatus(' boundary along X condition not implemented ', cart_rank)
+ end if
+ end do
+ end do
+ end do
+ case default
+ call test_substatus(' XXX error : wrong direction =', direction, cart_rank)
+ stop
+ end select
+ case default
+ velo = 1.
+ good_velo = 1.
+ end select
+
+
+end subroutine velo_init
+
+
+!> Initialisation of particle velocity field to test its interpolation
+!! @param[in] init = parameter to initialise the scalar fied to a constant one or to a sphere shape
+!! @param[out] velo = initial particles velocity
+!! @param[in] direction = current direction (along X,Y or Z-axis)
+!! @param[in] p_pos_adim = adimensionned particles postion (location where the velocity will be interpolated)
+!! @param[in,out] good_velo = analytic interpolation of the velocity field (on location p_pos)
+subroutine particle_velo_init(init, velo, direction, p_pos_adim, good_velo)
+
+ use test_common
+ use cart_topology
+
+ character(len=*), intent(in) :: init
+ real(WP), dimension(:), intent(inout) :: velo
+ real(WP), dimension(:), intent(in) :: p_pos_adim
+ integer, intent(in) :: direction
+ real(WP), dimension(:), intent(inout) :: good_velo
+
+ real(WP) :: dist ! distance from original position for translation case
+ integer :: ind ! particle indice
+
+
+ select case(init)
+ case('constant')
+ velo = 1.
+ good_velo = 1.
+ case('translation_field')
+ do ind = 1, size(velo)
+ velo(ind) = (float(ind-1+coord(direction)*N_proc(direction))/N(direction))
+ if (periods(direction) .eqv. .true.) then
+ dist = (p_pos_adim(ind)-1+coord(direction)*N_proc(direction))*d_sc(direction)
+ dist = modulo(dist, length(direction))
+ ! See direction 1 for explaination
+ if (dist>length(direction)-d_sc(direction)) &
+ & dist = (length(direction)-dist)*(length(direction)-d_sc(direction))/d_sc(direction)
+ good_velo(ind) = dist/length(direction)
+ else
+ call test_substatus(' boundary condition not implemented ', cart_rank)
+ end if
+ end do
+ case default
+ velo = 1.
+ good_velo = 1.
+ end select
+
+end subroutine particle_velo_init
+
+
+!> Initialisation of paticles and velocity field to provide setups to test advection
+!! @param[in] init = parameter used to choose between the different setup
+!! @param[in,out] dt = time step (used to compute solution)
+!! @param[in] shift = global translation of indices (optional)
+!! @param[out] scal3D = scalar field
+!! @param[out] velo = velocity field along one direction
+!! @param[in] direction = current direction (along X,Y or Z-axis)
+!! @param[out] good_scal = analytic solution of the advection problem
+subroutine scal_velo_init_part(init, dt, shift, scal3D, velo, direction, good_scal)
+
+ ! Scales code
+ use cart_topology
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ ! Test procedures
+ use test_common
+
+ character(len=*), intent(in) :: init
+ real(WP), intent(inout) :: dt
+ integer, intent(in) :: shift
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: velo
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: scal3D
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)), intent(out) :: good_scal
+ integer, intent(in) :: direction
+
+ integer :: i, j, k ! mesh indices
+ real(WP) :: cfl ! ratio between time and space steps
+ real(WP) :: t ! some time indication
+ real(WP) :: dt_bis ! time step used to compute trajectories
+ ! with a numerical integration
+ real(WP) :: sX, sY, sZ ! some temp variable
+ real(WP), dimension(3) :: vect_dir ! some temp variable
+
+
+ cfl = dt/d_sc(direction)
+
+
+ ! -- Initialize velocity and compute some trajectories --
+ select case(init)
+ case('left')
+ ! -- Test case 1 : only left block, no tag --
+ velo = (shift+0.3)/cfl
+ scal3D = -dt*velo
+ call test_substatus('particle- no tag, only left block', cart_rank)
+
+ case('tag')
+ ! Update dt in order to create "chock" without broke the stability condition
+ dt = 0.8*d_sc(direction)/sqrt(2*1.2*bl_size)
+ cfl = dt/d_sc(direction)
+ ! Compute trajectories
+ scal3D = 0.0
+ do k = 1, N_proc(3)
+ do j = 1, N_proc(2)
+ do i = 1, N_proc(1)
+ velo(i,j,k) = compute_velo_tag(dble(j), shift, cfl, direction)
+ dt_bis = min(0.01_WP, dt/10)
+ t = 0
+ do while(t <= dt-dt_bis)
+ scal3D(i,j,k) = scal3D(i,j,k) &
+ &- dt_bis*compute_velo_tag(j+scal3D(i,j,k), shift, cfl, direction)/d_sc(direction)
+ t = t + dt_bis
+ end do
+ dt_bis = dt - t
+ scal3D(i,j,k) = scal3D(i,j,k) &
+ &- dt_bis*compute_velo_tag(j+scal3D(i,j,k), shift, cfl, direction)/d_sc(direction)
+ end do
+ end do
+ end do
+ call test_substatus('particle- 2 tag, left and center', cart_rank)
+
+ case default ! default = 'center'
+ ! Test case 2 : only center block, no tag
+ velo = (shift+0.8)/cfl
+ scal3D = -dt*velo
+ call test_substatus('particle- no tag, only center block', cart_rank)
+ end select
+
+ ! -- Compute solution of the advection problem
+ vect_dir = 0
+ vect_dir(direction) = 1
+ do k = 1, N_proc(3)
+ sZ = (k-1+(coord(3)*N_proc(3)))*d_sc(3)
+ do j = 1, N_proc(2)
+ sY = (j-1+(coord(2)*N_proc(2)))*d_sc(2)
+ do i = 1, N_proc(1)
+ sX = (i-1+(coord(1)*N_proc(1)))*d_sc(1)
+ good_scal(i,j,k) = cos(2*M_PI*(sZ+vect_dir(3)*scal3D(i,j,k))/length(3))
+ good_scal(i,j,k) = good_scal(i,j,k)*cos(2*M_PI*(sY+vect_dir(2)*scal3D(i,j,k))/length(2))
+ !good_scal(i,j,k) = good_scal(i,j,k)*cos(3*2*M_PI*(sY+vect_dir(2)*scal3D(i,j,k))/length(2))
+ good_scal(i,j,k) = good_scal(i,j,k)*cos(2*M_PI*(sX+vect_dir(1)*scal3D(i,j,k))/length(1))
+ !good_scal(i,j,k) = good_scal(i,j,k)*cos(5*2*M_PI*(sX+vect_dir(1)*scal3D(i,j,k))/length(1))
+ scal3D(i,j,k) = cos(2*M_PI*sZ/length(3))
+ scal3D(i,j,k) = scal3D(i,j,k)*cos(2*M_PI*sY/length(2))
+ !scal3D(i,j,k) = scal3D(i,j,k)*cos(3*2*M_PI*sY/length(2))
+ scal3D(i,j,k) = scal3D(i,j,k)*cos(2*M_PI*sX/length(1))
+ !scal3D(i,j,k) = scal3D(i,j,k)*cos(5*2*M_PI*sX/length(1))
+ end do
+ end do
+ end do
+
+end subroutine scal_velo_init_part
+
+!> Compute a velocity field wich produce 2 tagged block during an advection step
+!! with the solver based on particle method
+!! @param[in] pos = relative position along current direction
+!! @param[in] shift = shift (in number of mesh)
+!! @param[in] cfl = time step/space step
+!! @param[in] direction = current direction
+!! @return res = velocity field
+function compute_velo_tag(pos, shift, cfl, direction) result(res)
+
+ ! Topology
+ use cart_topology
+ ! Solver information
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ ! Test tools
+ use test_common
+
+ real(WP), intent(in) :: pos, cfl
+ integer, intent(in) :: shift, direction
+ real(WP) :: res
+ real(WP) :: pos_abs ! absolute position (i,j,k are relative position in the current processus)
+ integer :: ind_tag_bl, ind_tag_p
+
+ ind_tag_bl = (nb_proc_dim(direction)*(N(direction)/bl_size)/3)! - (bl_number(direction)*coord(direction))
+ ind_tag_p = (ind_tag_bl-1)*bl_size + bl_size/2 + 1
+
+ pos_abs = pos + coord(direction)*N_proc(direction)
+
+ res = shift/cfl
+ if ((pos_abs >= ind_tag_p).and.(pos_abs < N(direction))) then
+ res = res + 0.8*(1.0-(pos_abs-ind_tag_p)/(N(direction)-ind_tag_p))/cfl
+ end if
+
+end function compute_velo_tag
+
+
+!> Initialisation of particle position for a group
+!! @param[in] direction = current direction
+!! @param[in] gs = group_size
+!! @param[in] shift = shift (in number of mesh)
+!! @param[out] p_pos = scalar field
+!! @param[out] bl_type = bloc type (left/center), optional
+subroutine pos_gp_init(direction, gs, shift, p_pos, bl_type)
+
+ ! Topology
+ use cart_topology
+ ! Solver information
+ use advec_common ! Some porcedure common to advection along all directions
+ use advec_variables ! contains info about solver parameters and others.
+ ! Test tools
+ use test_common
+
+ integer, intent(in) :: shift, direction
+ integer, dimension(2), intent(in) :: gs
+ real(WP), dimension(N_proc(direction), gs(1), gs(2)), intent(out) :: p_pos
+ logical, dimension(bl_nb(direction)+1, gs(1), gs(2)), intent(inout), optional :: bl_type
+
+ integer :: ind, ind2 ! some indice (line coordiante, particle indice)
+
+ ! ===== Each line of the group is initialized considering it second indice =====
+ ind2 = 1
+ do while(ind2<=gs(2))
+ ! Init are done with a cycle of five
+ select case(modulo(ind2,5))
+ case(1)
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,ind2) = ind - 2.1 + shift*N_proc(direction)
+ end do
+ if(present(bl_type)) bl_type(:,:,ind2) = .true.
+ case(2)
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,ind2) = ind - 1.1 + shift*N_proc(direction)
+ end do
+ if(present(bl_type)) bl_type(:,:,ind2) = .true.
+ case(3)
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,ind2) = ind + shift*N_proc(direction)
+ end do
+ if(present(bl_type)) bl_type(:,:,ind2) = .false.
+ case(4)
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,ind2) = ind + 1.1 + shift*N_proc(direction)
+ end do
+ if(present(bl_type)) bl_type(:,:,ind2) = .false.
+ case default
+ do ind = 1, N_proc(direction)
+ p_pos(ind,:,ind2) = ind + 2.1 + shift*N_proc(direction)
+ end do
+ if(present(bl_type)) bl_type(:,:,ind2) = .false.
+ end select
+
+ ind2 = ind2 +1
+ end do
+
+end subroutine pos_gp_init
+
+
+end module advec_aux_init
+!> @}
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_main.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..795eae187da98355231f9724504a32ff2b2af9f0
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_advec/advec_main.f90
@@ -0,0 +1,213 @@
+!> @addtogroup part_test
+!! @{
+
+!------------------------------------------------------------------------------
+!
+! PROGRAM : advec_main
+!
+! DESCRIPTION:
+!> This program use the function implemented in the module advec_aux to
+!! test the advection solver.
+!!
+!! @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!> @details
+!! All these test are unit test: they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! All the "test_part_*" function are devoted to validate the particular
+!! solver
+!!
+!! The following test are included:
+!! - Validate the particular method, step by step
+!! - Test the procedure "AC_obtain_senders" from advec_common
+!! - Validate the redistribution the buffer during the remeshing
+!! - Validate the redistribution the buffer during the remeshing -
+!! debug version : only one processus contains non-zero field.
+!! - Validate the remeshing of untagged particles
+!! - Validate the velocity interpolation (the RK2 scheme use the
+!! velocity at midlle point to advec particles).
+!! - Validate how type (left or center) and tag are computing for a
+!! single line
+!! - Validate how type (left or center) and tag are computing for a
+!! group of line
+!! - Validate an advection solver (in advec_aux)
+!! - advec a ball with a constant velocity
+!! - advec a ball with a spheric velocity field (the ball turns)
+!! - Advection with radial shear. This test also validate the remeshing
+!! of tagged particles.
+!!
+!
+!------------------------------------------------------------------------------
+
+program advec_main
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ ! Test procedures
+ use test_common
+ use advec_aux
+ use advec_aux_common
+ use advec_aux_common_line
+
+ implicit none
+
+ logical :: error = .false. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc,nb_procZ ! number of processus
+ integer :: i ! some boucle indice
+ integer :: direction ! along X (1), Y (2) or Z (3)
+
+ ! ===== Initialisation =====
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .false.
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ nb_procZ = 1
+ if ((mod(nb_proc,5)==0).and.(mod(default_size, nb_proc/5)==0)) then
+ nb_procZ = 5
+ nb_proc = nb_proc/5
+ else if ((mod(nb_proc,2)==0).and.(mod(default_size, nb_proc/2)==0)) then
+ nb_procZ = 2
+ nb_proc = nb_proc/2
+ else
+ if (mod(default_size, nb_proc)/=0) stop 'wrong number of processes : it have to divide 100'
+ end if
+ call cart_create((/ nb_proc, nb_procZ /), ierr)
+ call discretisation_default()
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! ===== Test about procedures involved in remeshing process =====
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('particle method - remeshing', rank_world)
+
+ ! Does it well compute who communicate with who during remeshing ?
+ error = test_part_AC_obtain_senders()
+ call test_status(error, 'obtain_senders sans shift', rank_world)
+ error = test_part_AC_obtain_senders(1)
+ call test_status(error, 'obtain_senders avec shift', rank_world)
+ error = test_part_AC_obtain_senders(3*nb_proc_dim(2)+2)
+ call test_status(error, 'obtain_senders avec large shift', rank_world)
+
+ ! The remeshing are done in a buffer. Is it well re-distribuate on processes ?
+ do i = 0, min(4, nb_proc-1)
+ error = test_part_AC_bufferToScalar_Deb(i)
+ call test_status(error, 'bufferToScalar deb, no shift, rank =', i, rank_world)
+ error = test_part_AC_bufferToScalar_Deb(i,1)
+ call test_status(error, 'bufferToScalar deb,shift; rank =', i, rank_world)
+ end do
+ error = test_part_AC_bufferToScalar()
+ call test_status(error, 'bufferToScalar sans shift', rank_world)
+ error = test_part_AC_bufferToScalar(1)
+ call test_status(error, 'bufferToScalar avec shift', rank_world)
+ error = test_part_AC_bufferToScalar(3*nb_proc_dim(2)+2)
+ call test_status(error, 'bufferToScalar avec large shift', rank_world)
+
+ ! Test remeshing of untagged particles
+ error = test_part_remesh_no_tag()
+ call test_status(error, 'remeshing of cst field advected a cst v', rank_world)
+ error = test_part_remesh_no_tag('translation_field')
+ call test_status(error, 'remeshing of uncst field advected a cst v', rank_world)
+ error = test_part_remesh_no_tag(order_opt='p_O4')
+ call test_status(error, 'O4: remeshing of cst field advected a cst v', rank_world)
+ error = test_part_remesh_no_tag('translation_field', order_opt='p_O4')
+ call test_status(error, 'O4: remeshing of uncst field advected a cst v', rank_world)
+ error = test_part_remesh_no_tag(order_opt='p_M6')
+ call test_status(error, 'Mprime 6: remeshing of cst field advected a cst v', rank_world)
+ error = test_part_remesh_no_tag('translation_field', order_opt='p_M6')
+ call test_status(error, 'Mprime 6: remeshing of uncst field advected a cst v', rank_world)
+
+
+ ! ===== Test about procedures involved in computation of particles advection =====
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('particle: velocity interpolation', rank_world)
+
+ ! Test auxiliary procedures
+ error = test_part_AC_obtain_recevers()
+ call test_status(error, 'AC_obtain_recevers', rank_world)
+
+ ! Test velocity interpolation
+ error = test_part_AC_interpol_velocity(2, 0)
+ call test_status(error, 'velocity interpolation, no shift', rank_world)
+ error = test_part_AC_interpol_velocity(2, 1)
+ call test_status(error, 'velocity interpolation, shift', rank_world)
+
+ ! Test group variants
+ call test_title('particle: velocity interpolation (group)', rank_world)
+ call set_group_size(5)
+ error = test_part_AC_velo_determine_com(0)
+ call test_status(error, 'velocity: communication', rank_world)
+ error = test_part_AC_velo_determine_com(1)
+ call test_status(error, 'velocity: communication, shift', rank_world)
+ do direction = 1, 3
+ error = test_part_AC_velo_compute_group(direction,0)
+ call test_status(error, 'velocity: interpol', direction, rank_world)
+ end do
+
+ ! ===== Test others =====
+ call test_title('particle method - tag and bloc type', rank_world)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ error = test_part_AC_type_and_block_O2()
+ call test_status(error, 'determine block type and tag particles', rank_world)
+ error = test_part_AC_type_and_block_O2_group()
+ call test_status(error, 'block and type for a group of line', rank_world)
+
+ ! ===== Test solvers =====
+
+ ! Test devoted to solver based on particles method
+ call test_title('particle method - advection test', rank_world)
+ error = test_part_advec_1D()
+ call test_status(error, 'advection - center block, no tag', rank_world)
+ error = test_part_advec_1D('left')
+ call test_status(error, 'advection - left block, no tag', rank_world)
+ verbose_more = .true.
+ error = test_part_advec_3D()
+ call test_status(error, 'advection - 3D tests', rank_world)
+ verbose_more = .false.
+
+ ! Idem for order 4 (corrected lambda 4)
+ call test_title('particle method - advection test', rank_world)
+ error = test_part_advec_1D(order_opt='p_O4')
+ call test_status(error, 'advection - center block, no tag', rank_world)
+ error = test_part_advec_1D('left', order_opt='p_O4')
+ call test_status(error, 'advection - left block, no tag', rank_world)
+ verbose_more = .true.
+ error = test_part_advec_3D(order='p_O4')
+ call test_status(error, 'advection - 3D tests', rank_world)
+ verbose_more = .false.
+
+ ! Idem for order M'6 remeshing formula
+ call test_title('particle method - advection test', rank_world)
+ error = test_part_advec_1D(order_opt='p_M6')
+ call test_status(error, 'advection - center block, no tag', rank_world)
+ error = test_part_advec_1D('left', order_opt='p_M6')
+ call test_status(error, 'advection - left block, no tag', rank_world)
+ verbose_more = .true.
+ error = test_part_advec_3D(order='p_M6')
+ call test_status(error, 'advection - 3D tests', rank_world)
+ verbose_more = .false.
+
+ ! Generic test
+! call mpi_barrier(MPI_COMM_WORLD, ierr)
+! call test_title('generic advection test', rank_world)
+! error = test_advec_rot()
+! call test_status(error, 'turning sphere', rank_world)
+
+
+ call mpi_finalize(ierr)
+
+end program advec_main
+
+!> @}
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_io/io_aux.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_io/io_aux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..12bfa054bb70c8f3a23f84cc798522c0e77bcf7b
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_io/io_aux.f90
@@ -0,0 +1,98 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : io_main
+!
+! DESCRIPTION:
+!> This files contains binary test on io procedures.
+!!
+!! @details
+!! All these test are unit test : they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! This first version test only the output at vtk xml format in parallel context.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module io_aux
+
+ implicit none
+
+ public :: test_io_output
+
+
+contains
+
+function test_io_output() result(success)
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ use cart_mesh
+ use parallel_io_bin
+ ! Test procedures
+ use test_common
+
+ implicit none
+
+ logical :: success ! logical result
+ real(WP), dimension(N_proc(1),N_proc(2),N_proc(3)) :: field ! constant field used in this test
+ integer :: tag_cst ! tag for constant field used in this test
+ integer :: tagX,tagY,tagZ ! tag for unconstant fields used in this test
+ integer :: i ! some boucle indice
+
+
+ success = .true.
+
+ ! Initialize output context
+ call parallel_io_init_all(4, nb_proc_dim, length, myrank, coord, './io_res/')
+ call test_substatus('general context intialization', success, myrank)
+
+ call parallel_io_init_field('cst', tag_cst)
+ call parallel_io_init_field('X', tagX)
+ call parallel_io_init_field('Y', tagY)
+ call parallel_io_init_field('Z', tagZ)
+ call test_substatus('fields context intialization', success, myrank)
+
+ ! Make some output
+ field = 1.0
+ call parallel_write(tag_cst, field, 'cst')
+ field = 2.0
+ call parallel_write(tag_cst, field, 'cst')
+ call test_substatus('constant output', success, myrank)
+
+ do i = 1, N_proc(1)
+ field(i,:,:) = i+coord(1)*N_proc(1)
+ end do
+ call parallel_write(tag_cst, field, 'X')
+ field = 2*field
+ call parallel_write(tag_cst, field, 'X')
+ call test_substatus('X output', success, myrank)
+
+ do i = 1, N_proc(2)
+ field(:,i,:) = i+coord(2)*N_proc(2)
+ end do
+ call parallel_write(tag_cst, field, 'Y')
+ call test_substatus('Y output', success, myrank)
+
+ do i = 1, N_proc(3)
+ field(:,:,i) = i+coord(3)*N_proc(3)
+ end do
+ call parallel_write(tag_cst, field, 'Z')
+ call test_substatus('Z output', success, myrank)
+
+
+ ! Free memory
+ call parallel_io_finish()
+
+ ! The main programm want receive a signal corresponding to error rather than success
+ success = .not. success
+
+end function test_io_output
+
+end module io_aux
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_io/io_main.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_io/io_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..45c63c1ffb8ea73177415dd7e6b1d4138a39eade
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_io/io_main.f90
@@ -0,0 +1,78 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : io_main
+!
+! DESCRIPTION:
+!> This program use the function implemented in the module io_aux to
+!! test the io routines.
+!!
+!! @details
+!! All these test are unit test : they return a logical value to check if
+!! the code version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!! This first version test only the output at vtk xml format in parallel context.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program io_main
+
+ ! External Library
+ use mpi
+ ! Scales code
+ use cart_topology
+ use parallel_io_bin
+ ! Test procedures
+ use test_common
+ use io_aux
+
+ implicit none
+
+ logical :: error = .false. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc,nb_procZ ! number of processus
+ integer :: i ! some boucle indice
+
+ ! ===== Initialisation =====
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .true.
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ nb_procZ = 1
+ if ((mod(nb_proc,5)==0).and.(mod(100, nb_proc/5)==0)) then
+ nb_procZ = 5
+ nb_proc = nb_proc/5
+ else if ((mod(nb_proc,2)==0).and.(mod(100, nb_proc/2)==0)) then
+ nb_procZ = 2
+ nb_proc = nb_proc/2
+ else
+ if (mod(100, nb_proc)/=0) stop 'wrong number of processes : it have to divide 100'
+ end if
+ call cart_create((/ nb_proc, nb_procZ /), ierr)
+ call discretisation_default()
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+
+ ! ===== Test about io procedures =====
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_title('io - parallel vtk xml', rank_world)
+ error = test_io_output()
+ call test_status(error, 'write output', rank_world)
+ !error = test_io_input()
+ !call test_status(error, 'write input', rank_world)
+
+ call mpi_finalize(ierr)
+
+end program io_main
+
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a3e19682ae6e79ea9671d702aa371aae10a48a2c
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux.f90
@@ -0,0 +1,274 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: topo_aux
+!
+! DESCRIPTION:
+!> This module provides different tests to validate the topology and the
+!! interface with the different data structures.
+!!
+!! @details
+!! Different automatic test are developped in order to check the mesh creation
+!! and the interface between the two data structures (the one used for the
+!! particular method and the one from the spectral part).
+!! All these test are unit test : they return a logical value to check if
+!! the ierr version pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!!
+!! The following test are included :
+!! 1 -> Initialise the topology, check the number of processes and
+!! the communicators.
+!! 2 -> Check the periodicity.
+!! 3 -> Check if the subgrid on each processus have the good size
+!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module topo_aux
+
+ use mpi
+ use cart_topology
+ use string
+ use precision
+ implicit none
+
+ real(WP), private :: epsilon_success = 1e-4 ! Error tolerance
+
+
+ ! Public procedures
+
+ ! ===== Test the topology =====
+ ! Public function
+ public :: test_topo_init
+ public :: test_topo_perio
+ public :: test_topo_submesh
+
+
+
+
+contains
+
+!> Test the topology initialisation
+!! @return success = logical success (= false if the ierr pass the test)
+!! @details
+!! Test the cartesian topology : check the number of processes and the
+!! communicators.
+function test_topo_init() result(success)
+
+ use test_common
+
+ logical :: success ! success status
+
+ integer :: ierr ! mpi success ierr
+ integer :: nb_proc ! total number of processus
+ integer :: nb_Y, nb_Z ! actual number of processus in each direction
+ integer, dimension(2) :: dims ! wanted number of processus in Y and Z direction
+
+ success = .true.
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+
+ ! Cut the domain along Y and initialize the toppology
+ dims = (/ nb_proc, 1 /)
+ call cart_create(dims, ierr)
+
+ ! Check the number of process in each communicator
+ call mpi_comm_size(Y_comm, nb_Y, ierr)
+ if (nb_Y /= nb_proc) then
+ call test_substatus('number of processes in Y_comm', nb_Y, myrank)
+ call test_substatus('and it must be', nb_proc, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ call mpi_comm_size(Z_comm, nb_Z, ierr)
+ if (nb_Z /= 1) then
+ call test_substatus('number of processes in Z_comm', nb_Z, myrank)
+ call test_substatus('and it must be', 1, myrank)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+ ! Compare it with the one saved in cart_topo
+ if (nb_Y /= nb_proc_dim(2)) then
+ call test_substatus('number of processes in Y_comm', nb_Y, myrank)
+ call test_substatus('and the solver beleave it is', nb_proc_dim(2), myrank)
+ success = .false.
+ end if
+ if (nb_Z /= nb_proc_dim(3)) then
+ call test_substatus('number of processes in Y_comm', nb_Z, myrank)
+ call test_substatus('and the solver beleave it is', nb_proc_dim(3), myrank)
+ success = .false.
+ end if
+
+ ! Return error = not succes
+ success = .not. success
+
+end function test_topo_init
+
+!> Check if it provide the right cartesian structure with a good periodicity
+!! @return success = logical success (= false if the ierr pass the test)
+function test_topo_perio() result(success)
+
+ use test_common
+
+ logical :: success ! success status
+
+ integer :: ierr ! mpi success ierr
+ integer :: rankP, rankN ! rank of previous and next (for shift)
+ integer :: nb_Y, nb_Z ! number of processus in each direction
+ integer, dimension(2) :: dims ! number of processus in Y and Z direction
+ integer, dimension(3) :: coord_bis ! coordonate of another processus
+ integer :: new_coord ! theoritical coordinate
+
+ success = .true.
+
+ ! Get the size
+ call mpi_comm_size(Y_comm, nb_Y, ierr)
+ call mpi_comm_size(Z_comm, nb_Z, ierr)
+
+ ! Shift along Y
+ ! Positive shift
+ call mpi_cart_shift(cart_comm, 2-1, 1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y-1 on rank', myrank, printer)
+ call test_substatus('theoritical Y-1', new_coord, printer)
+ call test_substatus('computed Y-1', coord_bis(2), printer)
+call test_substatus('X', coord_bis(1), printer)
+call test_substatus('Z', coord_bis(3), printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+1 on rank', myrank, printer)
+ success = .false.
+ end if
+ ! Negative shift
+ call mpi_cart_shift(cart_comm, 2-1, -1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y-(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('topo and periodicity along Y', success, myrank)
+
+ ! Shift along Z
+ ! Positive shift
+ call mpi_cart_shift(cart_comm, 3-1, 1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)-1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z-1 on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)+1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z+1 on rank', myrank, printer)
+ success = .false.
+ end if
+ ! Negative shift
+ call mpi_cart_shift(cart_comm, 3-1, -1, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)-1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z+(-1) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(3)+1, nb_Z)
+ if ((coord_bis(3) /=(new_coord)).OR.(coord_bis(2)/=coord(2)) ) then
+ call test_substatus('wrong Z-(-1)) on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('topo and periodicity along Z', success, myrank)
+
+ ! Big shift
+ call mpi_cart_coords(cart_comm, myrank, 3, coord, ierr)
+ call mpi_cart_shift(cart_comm, 2-1, 1+2*Nb_Y, rankP, rankN, ierr)
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankP, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)-1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y- on rank', myrank, printer)
+ call test_substatus('theoritical Y-', new_coord, printer)
+ call test_substatus('computed Y-', coord_bis(2), printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call mpi_cart_coords(cart_comm, rankN, 3, coord_bis, ierr)
+ new_coord = modulo(coord(2)+1, nb_Y)
+ if ((coord_bis(2) /=(new_coord)).OR.(coord_bis(3)/=coord(3)) ) then
+ call test_substatus('wrong Y+ on rank', myrank, printer)
+ success = .false.
+ end if
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+ call test_substatus('huge shift along Y', success, myrank)
+
+ ! Return error = not success
+ success = .not.success
+
+end function test_topo_perio
+
+
+!> Test the construction of subdomain and the mesh size in each processus
+!! @return success = logical success (= false if the ierr pass the test)
+!! @details
+!! Check if the subgrid on each processus have the good size
+function test_topo_submesh() result(success)
+
+ use test_common
+
+ logical :: success
+ integer :: ierr ! mpi success code
+
+ success = .true.
+
+ call discretisation_default()
+
+ ! Check the number of mesh
+ if (N_proc(1)/= 100) then
+ call test_substatus('local number of mesh along X', N_proc(1), myrank)
+ success = .false.
+ end if
+ if (N_proc(2)/= 100/nb_proc_dim(2)) then
+ call test_substatus('local number of mesh along Y', N_proc(2), myrank)
+ success = .false.
+ end if
+ if (N_proc(3)/= 100/nb_proc_dim(3)) then
+ call test_substatus('local number of mesh along Z', N_proc(3), myrank)
+ success = .false.
+ end if
+
+ ! Return error = not success
+ success = .not.success
+
+ call mpi_barrier(MPI_COMM_WORLD, ierr)
+
+end function test_topo_submesh
+
+
+end module topo_aux
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux_interface.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux_interface.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a5e499172e377fad41383bcf3f7f5283c9b56f2d
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_aux_interface.f90
@@ -0,0 +1,72 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: topo_aux_interface
+! DESCRIPTION:
+!> This module provides different tests to validate the interface with the different
+!! data structures.
+!!
+!! @details
+!! Different automatic test are developped in order to check the interface between the
+!! two data structures (the one used for the particular method and the one from the
+!! spectral part). All these test are unit test : they return a logical value to check
+!! if the library pass it or not.
+!!
+!! That is all these test are logical function, they return true if the result
+!! is the right one and false otherwise.
+!!
+!! The following test are included :
+!! 1 -> Test the interface between the data structure in the advection solver
+!! based on particular method and the one used in the
+!! pseudo-spectral method.
+!! X -> TODO check the output wich could be done directly from this
+!! format.
+!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module topo_aux_interface
+
+ use cart_topology
+ use precision
+
+ implicit none
+
+ ! ===== Test the topology =====
+ ! Public function
+ public :: test_topo_coupling
+
+contains
+
+!> Test the communication between the pseudo-spectral and particles method.
+!! @return success = logical success (= false if the ierr pass the test)
+!! @details
+!! Some advection-diffusion law on scalar field are solved by mixed numerical
+!! method. In such a case, the advection part are solved with a particular
+!! solver (with time order 2 and space-order of 2 or 4) and the diffusion part
+!! are compute with a pseudo-spectral solver. The operator splitting is a
+!! Strang splitting. All these method are provided in a parrallel
+!! implemention. The data distribution used in the pseudo-spectral solver is
+!! described in the module "datalayout" and the one used in the parrticle
+!! solver is described in cart_topology. Of course, to avoid useless
+!! communication and ensure efficient implementation, these data distribution
+!! are supposed to be the same between the storage of field in the real space
+!! described in "datalayout" and the one described in "cart_topology". This
+!! function are provided to test it and check if the procedure provided in the
+!! different solver are compatible.
+function test_topo_coupling() result(success)
+
+ use cart_topology
+
+ logical :: success
+
+ success = .true.
+
+
+ success = .not. success
+
+end function test_topo_coupling
+
+end module topo_aux_interface
diff --git a/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_main.f90 b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..440ad2b60d59c4721743b96538e47a7a2f430c9e
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/Test_topo/topo_main.f90
@@ -0,0 +1,60 @@
+!------------------------------------------------------------------------------
+!
+! PROGRAM : topo_main
+!
+! DESCRIPTION:
+!> Test the cartesian topology and all the associated variable.
+!! test the advection solver.
+!! This program perform all the test include in "topo_aux". This module provide
+!! unit test, ie logical function wich return a logical error.
+!! There is a verbosity parameter to decide to print on screen the status of
+!! result of each test (and sub-test) or not.
+!!
+!! See topo_aux for a list of available test.
+!!
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+program topo_main
+
+ use mpi
+ use topo_aux
+ use topo_aux_interface
+ use test_common
+
+ implicit none
+
+ logical :: error = .true. ! logical error
+ integer :: ierr ! mpi error code
+ integer :: rank_world ! processus rank on "MPI_COMM_WORLD"
+ integer :: nb_proc ! number of processus
+
+ ! Set the verbosity
+ verbose_test = .true.
+ verbose_more = .true.
+
+ ! Initialise mpi
+ call mpi_init(ierr)
+ call mpi_comm_size(MPI_COMM_WORLD, nb_proc, ierr)
+ call mpi_comm_rank(MPI_COMM_WORLD, rank_world, ierr)
+ call mpi_test_substatus(ierr, error, 'mpi initialization', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_init()
+ call test_status(error, '(mpi) topology initialisation', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_perio()
+ call test_status(error, 'periodicity', rank_world)
+
+ ! Initialize the topology and test is
+ error=test_topo_submesh()
+ call test_status(error, 'subdomain size', rank_world)
+
+ call mpi_finalize(ierr)
+
+end program topo_main
+
diff --git a/HySoP/src/Unstable/LEGI/test/src/test_common.f90 b/HySoP/src/Unstable/LEGI/test/src/test_common.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f2ffd7678ffe201dff3f47f0ea69f3756787213c
--- /dev/null
+++ b/HySoP/src/Unstable/LEGI/test/src/test_common.f90
@@ -0,0 +1,536 @@
+!------------------------------------------------------------------------------
+!
+! MODULE: test_advection
+!
+! DESCRIPTION:
+!> This module provide different tools useful to perform test.
+!
+!> @author
+!! Jean-Baptiste Lagaert, LEGI
+!
+!------------------------------------------------------------------------------
+
+module test_common
+
+ use string
+ use precision
+
+ implicit none
+
+ ! ===== Public variables =====
+ !> To print some status message during the test
+ logical :: verbose_test = .true.
+ !> More verbosity !
+ logical :: verbose_more = .true.
+ !> To choose wich processes lead the screen output
+ integer :: printer = 0
+
+ ! ===== Public procedure =====
+ ! - To print some information about the test (verbosity case)
+ public :: test_title
+ public :: test_status
+ public :: mpi_test_substatus
+ public :: test_substatus
+ public :: test_check_success
+
+ ! ===== Private procedure =====
+ private :: test_status_M
+ private :: test_status_MI
+ private :: test_substatus_M
+ private :: test_substatus_MI
+ private :: test_substatus_MR
+ private :: test_substatus_ML
+ private :: test_substatus_M3I
+ private :: test_check_success_S
+ private :: test_check_success_F
+ private :: test_check_success_F2
+ private :: test_check_success_F3
+ private :: test_check_success_FI
+ private :: test_check_success_FL
+ private :: test_check_success_F3L
+
+
+ ! ===== Private variables =====
+ !> Error tolerance
+ real(WP), private :: epsilon_success = 1e-4
+
+ ! ===== Interface =====
+ interface test_status
+ module procedure test_status_M, test_status_MI
+ end interface test_status
+
+ interface test_substatus
+ module procedure test_substatus_M, test_substatus_MI, test_substatus_MR &
+ & , test_substatus_ML, test_substatus_M3I
+ end interface test_substatus
+
+ interface test_check_success
+ module procedure test_check_success_S, test_check_success_F, &
+ & test_check_success_F2, test_check_success_F3, test_check_success_FI, &
+ & test_check_success_F2I, test_check_success_FL, test_check_success_F3L
+ end interface test_check_success
+
+
+
+contains
+
+!> Diffuse the error status and print the test status
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_title(message, rank)
+
+ use cart_topology
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ character(len=40) :: mess_bis ! message copy
+
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(A1,1X,A40)')'#', mess_bis
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_title
+
+
+!> Diffuse the error status and print the test status
+!! @param[in, out] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_status_M(error, message, rank)
+
+ use mpi
+ use cart_topology
+
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ character(len=40) :: mess_bis ! message copy
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(error .eqv. .true.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) error=.true.
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(5X,A2,2X,A40,X,A2,L2)')'->', mess_bis, '=', .not.error
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_status_M
+
+
+!> Diffuse the error status and print the test status
+!! @param[in, out] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] message_int = integer added to the information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_status_MI(error, message, message_int , rank)
+
+ use mpi
+ use cart_topology
+
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank, message_int
+
+ character(len=37) :: mess_bis ! message copy
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(error .eqv. .true.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) error=.true.
+
+ if((verbose_test).and.(rank==printer)) then
+ mess_bis = message
+ write(*,'(5X,A2,2X,A37,X,I2,X,A2,L2)')'->', mess_bis, message_int, '=', .not.error
+ if((verbose_more).and.(rank==printer)) print*,''
+ end if
+
+end subroutine test_status_MI
+
+
+!> Use a mpi error code to update the test status and print it
+!! @param[in] ierr = mpi error code
+!! @param[in] error = logical equal true if there is an error
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine mpi_test_substatus(ierr, error, message, rank)
+
+ use mpi
+
+ integer, intent(in) :: ierr
+ logical, intent(inout) :: error
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ if (ierr /= MPI_SUCCESS) then
+ error = .false.
+ end if
+
+ call test_substatus(message, error, rank)
+ error = .not. error
+
+end subroutine mpi_test_substatus
+
+!> Print a sub-status message
+!! @param[in] message = information message
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_M(message, rank)
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40)')'+', message
+ end if
+
+end subroutine test_substatus_M
+
+
+!> Print a sub-status message and a integer
+!! @param[in] message = information message
+!! @param[in] i = integer to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_MI(message, i, rank)
+
+ character(len =*), intent(in) :: message
+ integer, intent(in) :: i
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,I5)')'+', message, '=', i
+ end if
+
+end subroutine test_substatus_MI
+
+
+!> Print a sub-status message and a integer
+!! @param[in] message = information message
+!! @param[in] i = integer table of dimension 3 to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_M3I(message, i, rank)
+
+ character(len =*), intent(in) :: message
+ integer, dimension(3), intent(in) :: i
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,I3,X,A1,X,I3,X,A1,X,I3)')'+',message,'=',i(1),',',i(2),',',i(3)
+ end if
+
+end subroutine test_substatus_M3I
+
+
+!> Print a sub-status message and a real
+!! @param[in] message = information message
+!! @param[in] r = real to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_MR(message, r, rank)
+
+ use precision
+
+ character(len=* ), intent(in) :: message
+ real(WP), intent(in) :: r
+ integer, intent(in) :: rank
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,F8.5)')'+', message, '=', r
+ end if
+
+end subroutine test_substatus_MR
+
+
+!> Print a sub-status message and a logical (after sending its value if false)
+!! @param[in] message = information message
+!! @param[in,out] l = logical to print
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_substatus_ML(message, l, rank)
+
+ use precision
+ use mpi
+ use cart_topology
+
+ character(len =*), intent(in) :: message
+ logical, intent(inout) :: l
+ integer, intent(in) :: rank
+ integer :: error_int = 0
+ integer :: error_red = 0
+ integer :: ierr ! mpi error code
+
+ if(l .eqv. .false.) error_int = 1
+ call mpi_allreduce(error_int, error_red, 1, MPI_INTEGER, MPI_MAX, MPI_COMM_WORLD, ierr)
+ if(error_red==1) l=.false.
+
+ if((verbose_more).and.(rank==printer)) then
+ write(*,'(10X,A2,2X,A40,X,A1,X,L5)')'+', message, '=', l
+ end if
+
+end subroutine test_substatus_ML
+
+
+
+!> Check if the numerical success stay under a threshold - constant theoritical
+!! solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_S(scal1D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+
+ real(WP), intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ integer :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(scal1D - good_scal)
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', rank)
+ call test_substatus('max scal0D', maxval(scal1D), rank)
+ call test_substatus('min scal0D', minval(scal1D), rank)
+ call test_substatus('and it must be', good_scal, rank)
+ end if
+
+end subroutine test_check_success_S
+
+
+!> Check if two integer 1-dimensionnal table are equal.
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_FI(scal1D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+
+ integer, dimension(:),intent(in) :: good_scal ! theoritical value of scal1D
+ integer, dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ integer :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal1D - good_scal))
+
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', rank)
+ call test_substatus('max scal1D', maxval(scal1D), rank)
+ call test_substatus('min scal1D', minval(scal1D), rank)
+ call test_substatus('max solution', maxval(good_scal), rank)
+ end if
+
+end subroutine test_check_success_FI
+
+
+!> Check if two integer 2-dimensionnal table are equal.
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_F2I(array2D, good_array, success, rank)
+
+ use precision
+ use cart_topology
+
+ integer, dimension(:,:), intent(in) :: good_array ! theoritical value of array2D
+ integer, dimension(:,:), intent(in) :: array2D ! the computed value
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ integer :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(array2D - good_array))
+
+ if (success_inf>=0.5) then ! As we consider integer, this error is enough
+ success = .false.
+ call test_substatus('XXX error', rank)
+ call test_substatus('max array2D', maxval(array2D), rank)
+ call test_substatus('min array2D', minval(array2D), rank)
+ call test_substatus('max solution', maxval(good_array), rank)
+ end if
+
+end subroutine test_check_success_F2I
+
+
+!> Check if the numerical success stay under a threshold - 1D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal1D = numerical value of the scalar (1D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_F(scal1D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+
+ real(WP), dimension(:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:),intent(in) :: scal1D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ real(WP) :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal1D - good_scal))
+
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', rank)
+ call test_substatus('max scal1D', maxval(scal1D), rank)
+ call test_substatus('min scal1D', minval(scal1D), rank)
+ call test_substatus('max solution', maxval(good_scal), rank)
+ call test_substatus('min solution', minval(good_scal), rank)
+ end if
+
+end subroutine test_check_success_F
+
+
+!> Check if the numerical success stay under a threshold - 2D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal2D = numerical value of the scalar (2D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_F2(scal2D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+
+ real(WP), dimension(:,:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:,:),intent(in) :: scal2D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ real(WP) :: success_inf ! norm L_inf of the success
+
+ success_inf = maxval(abs(scal2D - good_scal))
+ if (success_inf>=epsilon_success) then
+ success = .false.
+ call test_substatus('XXX error', rank)
+ call test_substatus('max scal2D', maxval(scal2D), rank)
+ call test_substatus('min scal2D', minval(scal2D), rank)
+ call test_substatus('max solution', maxval(good_scal), rank)
+ call test_substatus('min solution', minval(good_scal), rank)
+ end if
+
+end subroutine test_check_success_F2
+
+
+!> Check if the numerical success stay under a threshold - 3D space-dependant analytic solution
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal3D = numerical value of the scalar (3D)
+!! @param[in] good_scal = theoritical value of the scalar
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_F3(scal3D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+ use mpi
+
+ real(WP), dimension(:,:,:),intent(in) :: good_scal ! theoritical value of scal1D
+ real(WP), dimension(:,:,:),intent(in) :: scal3D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ real(WP) :: success_inf ! norm L_inf of the success
+ real(WP) :: success_inf_gl ! norm L_inf of the success
+ integer :: ierr ! mpi error code
+
+integer, dimension(3) :: temp
+
+ success_inf = maxval(abs(scal3D - good_scal))
+ success_inf_gl=success_inf
+ call mpi_reduce(success_inf, success_inf_gl, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, MPI_COMM_WORLD, ierr)
+ if (success_inf_gl>=epsilon_success) success = .false.
+ call test_substatus('norm inf of error', success_inf_gl, rank)
+
+ if (success_inf>=epsilon_success) then
+ call test_substatus('XXX error', rank)
+ temp = minloc(scal3D - good_scal)
+ call test_substatus('error min in', temp, rank)
+ call test_substatus('scal3D', scal3D(temp(1), temp(2), temp(3)), rank)
+ call test_substatus('sol', good_scal(temp(1), temp(2), temp(3)), rank)
+ temp = maxloc(scal3D - good_scal)
+ call test_substatus('error max in', temp, rank)
+ call test_substatus('scal3D', scal3D(temp(1), temp(2), temp(3)), rank)
+ call test_substatus('sol', good_scal(temp(1), temp(2), temp(3)), rank)
+ end if
+
+end subroutine test_check_success_F3
+
+
+!> Check if two 1D logical field are identical or not
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal3D = numerical value of the logical field (1D)
+!! @param[in] good_scal = theoritical value
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_FL(scal3D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+ use mpi
+
+ logical, dimension(:),intent(in) :: good_scal ! theoritical value of scal1D
+ logical, dimension(:),intent(in) :: scal3D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ logical :: success_inf ! local error
+ logical :: success_inf_gl ! global error
+ integer :: ierr ! mpi error code
+
+
+ success_inf = all(scal3D .eqv. good_scal)
+ success_inf_gl=success_inf
+ call mpi_reduce(success_inf, success_inf_gl, 1, MPI_LOGICAL, MPI_LAND, 0, MPI_COMM_WORLD, ierr)
+
+ success = success_inf_gl
+
+end subroutine test_check_success_FL
+
+
+!> Check if two 3D logical field are identical or not
+!! @param[in,out] success = test success (= false if the code pass the test)
+!! @param[in] scal3D = numerical value of the logical field (3D)
+!! @param[in] good_scal = theoritical value
+!! @param[in] rank = mpi rank to avoid to print message for each processes (usefull if there is a lot of them)
+subroutine test_check_success_F3L(scal3D, good_scal, success, rank)
+
+ use precision
+ use cart_topology
+ use mpi
+
+ logical, dimension(:,:,:),intent(in) :: good_scal ! theoritical value of scal1D
+ logical, dimension(:,:,:),intent(in) :: scal3D ! the computed scalar field
+ logical, intent(inout) :: success
+ integer, intent(in) :: rank
+
+ logical :: success_inf ! local error
+ logical :: success_inf_gl ! global error
+ integer :: ierr ! mpi error code
+
+
+ success_inf = all(scal3D .eqv. good_scal)
+ success_inf_gl=success_inf
+ call mpi_reduce(success_inf, success_inf_gl, 1, MPI_LOGICAL, MPI_LAND, 0, MPI_COMM_WORLD, ierr)
+
+ success = success_inf_gl
+
+end subroutine test_check_success_F3L
+
+
+end module test_common
diff --git a/HySoP/src/Unstable/Plouhmans.f90 b/HySoP/src/Unstable/Plouhmans.f90
new file mode 100644
index 0000000000000000000000000000000000000000..30be1c63869d97b8cbfac1b33ef429573046142d
--- /dev/null
+++ b/HySoP/src/Unstable/Plouhmans.f90
@@ -0,0 +1,132 @@
+!> Temp modules for ppm_client
+module ppmExample
+
+ use ppm_module_init
+ use ppm_module_data, only : ppm_kind_double
+ use ppm_module_finalize
+
+ ! use client_io
+ use client_data, only: mk, dime
+ ! Physical domain and grid
+ use Domain
+ ! Fields on the grid
+ use Fields, only: init_fields, velocity, vorticity
+ ! Topology
+ use client_topology, only: init_topo, topo
+ ! Multigrid solver
+ !use Solver, only : init_multigrid, solve_poisson
+
+ use mpi
+ use WrapFort
+
+ implicit none
+
+ include "ppm_numerics.h"
+
+ integer, private :: info
+
+contains
+
+ subroutine init_client()
+
+ integer :: prec,tol
+ ! MPI comm
+ integer :: comm
+ ! debug mode
+ integer :: debug
+ ! error status
+ integer :: info
+ !======================
+ ! Init ppm
+ !======================
+ prec = ppm_kind_double ! Defined in ppm_param.h
+ comm = MPI_COMM_WORLD !
+ debug = 2
+ tol = -10
+ info = -1
+ call ppm_init(dime,prec,tol,comm,debug,info)
+
+ !======================
+ ! Read and broadcast
+ ! some parameters
+ !======================
+ ! call read_data()
+
+ !======================
+ ! Geometry and grid
+ !======================
+ call init_geometry()
+ call init_grid()
+
+ !======================
+ ! Creates the topology
+ !======================
+ call init_topo(domain_minCoords, domain_maxCoords, domain_bc, domain_ghostsize, grid_resolution)
+
+ !======================
+ ! Fields allocation
+ !======================
+ call init_fields(domain_ghostsize, topo)
+
+ !======================
+ ! Init solver
+ !======================
+! call init_multigrid(topo%ID, mesh%ID, domain_ghostsize, domain_bc)
+
+ !======================
+ ! Init Physics
+ !======================
+ velocity = 0.0_mk
+ vorticity = 0.0_mk
+
+ !======================
+ ! Init Particles
+ !======================
+
+ print *, "end of parmes:ppm:init_client"
+
+ end subroutine init_client
+
+ subroutine main_client() bind(c,name='plouhmans')
+
+ ! Multigrid parameters ...
+ print *, 'run ppm simulation ...'
+ ! init ppm ...
+ call init_client()
+
+! call solve_poisson(topo%ID, stream_function, vorticity)
+
+ call ppm_finalize(info)
+ print *, 'end ppm simulation'
+ end subroutine main_client
+
+ subroutine read_data()
+
+ ! Set precision
+! mpi_prec = MPI_DOUBLE_PRECISION
+
+!!$ ! Read input parameters on proc 0
+!!$ if(rank == 0) call readparams()
+!!$
+!!$
+!!$ call MPI_BCast(runtag,256,MPI_CHARACTER,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(iruntag,1,MPI_INTEGER,0,MPI_COMM_WORLD,info)
+!!$ !----------------------------------------------------------------------------!
+!!$ ! MPI Broadcasts ...
+!!$ !----------------------------------------------------------------------------!
+!!$ call MPI_BCast(nx,dime,MPI_INTEGER,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(min_physg,dime,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(max_physg,dime,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(dt,1,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(dt_max,1,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(tend,1,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(itend,1,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call MPI_BCast(nu,1,mpi_prec,0,MPI_COMM_WORLD,info)
+!!$ call mpi_bcast(verbose,1,mpi_logical,0,mpi_comm_world,info)
+!!$ call mpi_bcast(maxlev,1,mpi_integer,0,mpi_comm_world,info)
+
+
+
+ end subroutine read_data
+
+end module ppmexample
diff --git a/HySoP/src/Unstable/SetsIndicators.f90 b/HySoP/src/Unstable/SetsIndicators.f90
new file mode 100755
index 0000000000000000000000000000000000000000..6f38e3916b11c8defae84d5f203bcea196065af2
--- /dev/null
+++ b/HySoP/src/Unstable/SetsIndicators.f90
@@ -0,0 +1,516 @@
+!> Penalization stuff (init chi, penalize vorticity)
+!! Note : drag/lift are also computed with penalize routines.
+module SetsIndicators
+
+ use client_data
+ use VectorCalculus
+ !use client_topology, only : nsublist
+ use mpi,only:MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD
+ use Domain
+ implicit none
+
+ private
+
+ public :: init_obstacles,compute_control_box,compute_test,nocaForces,laplacian,chi_sphere,chi_boundary,chi_box,&
+ getMemoryForIndicators
+
+ ! Indicators functions
+ ! The top and bottom (z axis) boundaries
+ integer, dimension(:,:), pointer :: chi_boundary=>NULL()
+ ! The sphere
+ integer, dimension(:,:), pointer :: chi_sphere=>NULL()
+
+ ! Axes z is south-north, x down to upstream and y east-west
+ !> control volume function
+ integer, dimension(:,:), pointer :: chi_box => NULL()
+ !> north boundary ind. func (ie zmax)
+ integer, dimension(:,:), pointer :: chi_north => NULL()
+ !> south boundary ind. func (ie zmin)
+ integer, dimension(:,:), pointer :: chi_south => NULL()
+ !> east boundary ind. func (ie ymin)
+ integer, dimension(:,:), pointer :: chi_east => NULL()
+ !> west boundary ind. func (ie ymax)
+ integer, dimension(:,:), pointer :: chi_west => NULL()
+ !> upstream boundary ind. func (ie xmax)
+ integer, dimension(:,:), pointer :: chi_up => NULL() ! upstream
+ !> downstream boundary ind. func (ie xmin)
+ integer, dimension(:,:), pointer :: chi_down => NULL() ! downstream
+ !>
+ integer,parameter :: Down=1,Up=2,West=3,East=4,South=5,North=6
+ !> Normal to each face of the control volume
+ real(mk),dimension(dime,2*dime) :: normal
+ !> A buffer for force on control volume, used to save force value on previous time step
+ real(mk),dimension(dime)::bufferForce
+ !> normalisation factor used to compute the drag in the Noca's way
+ real(mk) :: coef
+ real(mk),parameter :: uinf=1.0
+
+ ! temp to avoid ppm dependence
+ integer, parameter :: nsublist = 1
+
+
+contains
+
+ !> compute chi functions for penalization at the boundaries to enforce dirichlet conditions on zmin and zmax
+ subroutine init_obstacles(resolution,step,lower,upper,center,radius,layer,coordMin)
+ !> Number of points in each dir
+ integer, dimension(dime), intent(in) :: resolution
+ !> Grid steps sizes
+ real(mk), dimension(dime), intent(in) :: step
+ !> Dimensions of the boundary layers
+ real(mk), dimension(dime), intent(in) :: upper,lower
+ !> position of the center of the sphere
+ real(mk),dimension(dime),intent(in):: center
+ !> Radius of the sphere
+ real(mk),intent(in) :: radius
+ !> Boundary layer thickness
+ real(mk), intent(in) :: layer
+ !> Coordinates of the lowest point of the local domain
+ real(mk),dimension(dime),intent(in) :: coordMin
+
+ integer, dimension(:,:), allocatable :: tmp_boundary,tmp_sphere
+ integer::istat,i,j,k
+ real(mk),dimension(dime) :: coords
+ real(mk) :: dist
+ integer :: sizeMaxChi,count_boundary,count_sphere
+ real :: layerMin,layerMax
+ sizeMaxChi = product(resolution)
+ allocate(tmp_boundary(dime,sizeMaxChi),stat=istat)
+ allocate(tmp_sphere(dime,sizeMaxChi),stat=istat)
+
+ layerMin = lower(c_Z) + layer
+ layerMax = upper(c_Z) - layer
+
+ if(istat.ne.0) stop 'Chi-boundaries function allocation error.'
+ count_boundary=0
+ count_sphere =0
+ do k=1,resolution(c_Z)
+ coords(c_Z)=coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)
+ coords(c_Y)=coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)
+ coords(c_X)=coordMin(c_X) + (i-1)*step(c_X)
+ if( (coords(c_Z)>layerMax).or.(coords(c_Z)<layerMin)) then
+ count_boundary=count_boundary+1
+ tmp_boundary(c_X,count_boundary)=i
+ tmp_boundary(c_Y,count_boundary)=j
+ tmp_boundary(c_Z,count_boundary)=k
+ end if
+ dist = dot_product(coords-center,coords-center) - radius**2
+ if(dist <=0.0) then ! We are on or in the sphere ...
+ count_sphere=count_sphere+1
+ tmp_sphere(c_X,count_sphere)=i
+ tmp_sphere(c_Y,count_sphere)=j
+ tmp_sphere(c_Z,count_sphere)=k
+ end if
+ end do
+ end do
+ end do
+ allocate(chi_boundary(dime,count_boundary))
+ chi_boundary=tmp_boundary(:,1:count_boundary)
+ allocate(chi_sphere(dime,count_sphere))
+ chi_sphere=tmp_sphere(:,1:count_sphere)
+
+ deallocate(tmp_boundary,tmp_sphere)
+
+ end subroutine init_obstacles
+
+ !> Compute indicator functions for the control box (including a sphere ...)
+ ! This routine must fill all chi functions in
+ !> \param box_min coordinate of the lower point of the box
+ !> \param boxMax coordinate of the upper point of the box
+ !! We suppose (require) that boxMin+boxMax corresponds to grid points ...
+ subroutine compute_control_box(resolution,step,boxMin,boxMax,center,radius,coordMin)
+ !> Number of points in each dir (1st index) for each sub (2nd index)
+ integer, dimension(dime),intent(in) :: resolution
+ !> Grid steps sizes
+ real(mk), dimension(dime), intent(in) :: step
+ !> lower point of the box
+ real(mk),dimension(dime),intent(in) :: boxMin
+ !> upper point of the box
+ real(mk),dimension(dime),intent(in) :: boxMax
+ !> position of the center of the sphere
+ real(mk),dimension(dime),intent(in):: center
+ !> radius of the sphere
+ real(mk),intent(in) :: radius
+ !> Lower point of the domain
+ real(mk),dimension(dime),intent(in) :: coordMin
+
+ logical,dimension(dime) :: isMinIn,isMaxIn
+ real(mk),dimension(dime) :: coordMax,coords
+
+ integer, dimension(2*dime) :: ind
+ integer, dimension(2*dime) :: nbPoints
+ ! Size (number of points in each dir) of the control volume
+ integer(kind=8), dimension(dime) :: boxDim
+ real(mk) :: coord,dist
+ integer :: count,i,j,k,direction,count_box
+ integer(kind=8) :: nbPointsBox
+ integer,dimension(:,:),allocatable :: tmp_box
+
+ !> radius of the sphere
+ real(mk) :: radiusBis
+
+ ! Add an assert to check that the sphere radius is shorter thant the box size ...
+ radiusBis=radius!-step(c_Z)
+ ! First compute normals to the box boundaries
+ normal(:,:)=0.0
+ normal(c_X,Up)=1.0
+ normal(c_X,Down)=-1.0
+ normal(c_Y,West)=-1.0
+ normal(c_Y,East)=1.0
+ normal(c_Z,North)=1.0
+ normal(c_Z,South)=-1.0
+ ! Coordinates of the upper point
+ coordMax(:)=coordMin(:)+(resolution(:)-1)*step(:)
+ ! First : check if box boundaries are in the current domain
+ isMaxIn=.False.
+ isMinIn=.False.
+ where(coordMin <= boxMin) isMinIn=.True. ! Lower boundaries
+ where(coordMax >= boxMax) isMaxIn=.True. ! Upper boundaries
+
+ !! Look for local indices corresponding to the box boundaries (i.e. x,y,z = boxMin() and boxMax())
+ ! index order: Down,Up,West,East,South,North
+ ind=0 !
+ where(isMinIn(:).and.isMaxIn(:))
+ ind(1:2*dime:2)=1
+ ind(2:2*dime:2)=1
+ end where
+ where((.not.isMinIn(:)).and.(isMaxIn(:)))
+ ind(1:2*dime:2)=1
+ ind(2:2*dime:2)=1
+ end where
+ where((isMinIn(:)).and.(.not.isMaxIn(:)))
+ ind(1:2*dime:2)=1
+ ind(2:2*dime:2)=resolution(:)
+ end where
+
+ do direction=1,dime
+ do k=1,resolution(direction)
+ coord=coordMin(direction)+(k-1)*step(direction)
+ if(isMinIn(direction)) then
+ if(coord<boxMin(direction)) ind(2*direction-1)=k+1
+ end if
+ if(isMaxIn(direction)) then
+ if(coord<boxMax(direction)) then
+ ind(2*direction)=k+1
+ else
+ exit
+ end if
+ end if
+ end do
+ end do
+ ! ind now contains the number of the points that are on the box boundary, in each direction, in the following order :
+ ! ind(Down Up West East South North)
+
+ ! Remove last point to integrate properly ...
+ ind(2:2*dime:2)=ind(2:2*dime:2)-1
+
+ ! Count the number of points on each face and inside the domain
+ nbPoints=0
+ if(isMinIn(1)) nbPoints(Down)=(ind(East)-ind(West)+1)*(ind(North)-ind(South)+1)
+ if(isMaxIn(1)) nbPoints(Up)=(ind(East)-ind(West)+1)*(ind(North)-ind(South)+1)
+ if(isMinIn(3)) nbPoints(South)=(ind(East)-ind(West)+1)*(ind(Up)-ind(Down)+1)
+ if(isMaxIn(3)) nbPoints(North)=(ind(East)-ind(West)+1)*(ind(Up)-ind(Down)+1)
+ if(isMinIn(2)) nbPoints(East)=(ind(Up)-ind(Down)+1)*(ind(North)-ind(South)+1)
+ if(isMaxIn(2)) nbPoints(West)=(ind(Up)-ind(Down)+1)*(ind(North)-ind(South)+1)
+
+ boxDim(c_X)=ind(Up)-ind(Down)+1
+ boxDim(c_Y)=ind(East)-ind(West)+1
+ boxDim(c_Z)=ind(North)-ind(South)+1
+ nbPointsBox = boxDim(c_X)*boxDim(c_Y)*boxDim(c_Z)
+
+ allocate(tmp_box(dime,nbPointsBox))
+ allocate(chi_up(dime,nbPoints(Up)),chi_down(dime,nbPoints(Down)),chi_east(dime,nbPoints(East)),chi_west(dime,nbPoints(West)))
+ allocate(chi_south(dime,nbPoints(South)),chi_north(dime,nbPoints(North)))
+ count_box=0
+
+ if(all(boxDim>0)) then
+ do k=ind(South),ind(North)
+ coords(c_Z) = coordMin(c_Z)+(k-1)*step(c_Z)
+ do j=ind(West),ind(East)
+ coords(c_Y) = coordMin(c_Y)+(j-1)*step(c_Y)
+ do i=ind(Down),ind(Up)
+ coords(c_X) = coordMin(c_X)+(i-1)*step(c_X)
+ dist = dot_product(coords-center,coords-center) - radiusBis**2
+ if(dist >=0.0) then ! We are on or outside the sphere ...
+ count_box = count_box+1
+ tmp_box(c_X,count_box)=i
+ tmp_box(c_Y,count_box)=j
+ tmp_box(c_Z,count_box)=k
+ end if
+ end do
+ end do
+ end do
+ end if
+ allocate(chi_box(dime,count_box))
+ chi_box=tmp_box(:,1:count_box)
+
+ deallocate(tmp_box)
+ if(isMinIn(3)) then ! South boundary
+ count=1
+ chi_south(3,:)=ind(South)
+ do j=ind(West),ind(East)
+ do i=ind(Down),ind(Up)
+ chi_south(1,count)=i
+ chi_south(2,count)=j
+ count=count+1
+ end do
+ end do
+ end if
+ if(isMinIn(2)) then ! East boundary
+ count=1
+ chi_east(2,:)=ind(East)+1
+ do k=ind(South),ind(North)
+ do i=ind(Down),ind(Up)
+ chi_east(1,count)=i
+ chi_east(3,count)=k
+ count=count+1
+ end do
+ end do
+ end if
+ if(isMinIn(1)) then ! Downstream boundary is in the domain
+ count=1
+ chi_down(1,:)=ind(Down)
+ do k=ind(South),ind(North)
+ do j=ind(West),ind(East)
+ chi_down(2,count)=j
+ chi_down(3,count)=k
+ count=count+1
+ end do
+ end do
+ end if
+
+ if(isMaxIn(3)) then ! North boundary is in the domain
+ count=1
+ chi_north(3,:)=ind(North)+1
+ do j=ind(West),ind(East)
+ do i=ind(Down),ind(Up)
+ chi_north(1,count)=i
+ chi_north(2,count)=j
+ count=count+1
+ end do
+ end do
+ end if
+ if(isMaxIn(2)) then ! West boundary is in the domain
+ count=1
+ chi_west(2,:)=ind(West)
+ do k=ind(South),ind(North)
+ do i=ind(Down),ind(Up)
+ chi_west(1,count)=i
+ chi_west(3,count)=k
+ count=count+1
+ end do
+ end do
+ end if
+ if(isMaxIn(1)) then ! Upstream boundary is in the domain
+ count=1
+ chi_up(1,:)=ind(Up)+1
+ do k=ind(South),ind(North)
+ do j=ind(West),ind(East)
+ chi_up(2,count)=j
+ chi_up(3,count)=k
+ count=count+1
+ end do
+ end do
+ end if
+
+ bufferForce = 0.0
+ ! Compute coef used to calculate the drag in the Nocas's way
+ coef = 2./(uinf**2*pi*radius**2)
+
+ end subroutine compute_control_box
+
+
+ !> Set input field to one on the control volume boundaries and to zero elsewhere
+ subroutine compute_test(testfield,chi)
+ real(mk), dimension(:,:,:),pointer:: testfield
+ integer,dimension(:,:),pointer ::chi
+ integer :: k
+ do k=1,size(chi,2)
+ testfield(chi(1,k),chi(2,k),chi(3,k)) = 1.0
+ end do
+ end subroutine compute_test
+
+ !> Computation of the drag according to "method B" presented in
+ !! Noca99 or Plouhmans, 2002, Journal of Computational Physics
+ subroutine nocaForces(force,velo,vort,nu,coordMin,step,dt,dvol)
+
+ !> The force to be computed
+ real(mk), dimension(dime),intent(inout) :: force
+ !! velocity and vorticity fields, intent(in)
+ real(mk), dimension(:,:,:,:,:),pointer :: velo,vort
+ !> viscosity
+ real(mk),intent(in)::nu
+ !! Coordinates of the lowest point in the domain
+ real(mk),dimension(dime),intent(in):: coordMin
+ !! mesh step sizes
+ real(mk),dimension(dime),intent(in)::step
+ !> Time step
+ real(mk),intent(in)::dt
+ !> element. vol
+ real(mk),intent(in) ::dvol
+ ! Surface element
+ real(mk) :: dsurf
+ real(mk),dimension(dime)::localForce
+ integer :: info
+ localForce=0.0
+ force=0.0
+
+ ! Downstream and upstream surface
+ dsurf=step(c_Y)*step(c_Z)
+ call integrateOnSurface(localForce,velo,vort,chi_down,normal(:,Down),c_X,nu,dsurf,coordMin,step)
+ call integrateOnSurface(localForce,velo,vort,chi_up,normal(:,Up),c_X,nu,dsurf,coordMin,step)
+ ! East and West
+ dsurf=step(c_X)*step(c_Z)
+ call integrateOnSurface(localForce,velo,vort,chi_east,normal(:,East),c_Y,nu,dsurf,coordMin,step)
+ call integrateOnSurface(localForce,velo,vort,chi_west,normal(:,West),c_Y,nu,dsurf,coordMin,step)
+ ! North and south
+ dsurf=step(c_Y)*step(c_X)
+ call integrateOnSurface(localForce,velo,vort,chi_south,normal(:,South),c_Z,nu,dsurf,coordMin,step)
+ call integrateOnSurface(localForce,velo,vort,chi_north,normal(:,North),c_Z,nu,dsurf,coordMin,step)
+ ! over the volume ...
+ call integrateOnBox(localForce,vort,chi_box,dvol,dt,coordMin,step)
+
+ localForce=localForce*coef
+ !write(*,'(a,3f10.5)') ' drag local: ', localForce
+ call MPI_Reduce(localForce,force,dime,MPI_DOUBLE_PRECISION,MPI_SUM,0,MPI_COMM_WORLD,info)
+
+ end subroutine nocaForces
+
+ !> Return -1/(dime-1)*d/dt int_over_control_box coord X vorticity
+ subroutine integrateOnBox(force,vort,chi,dvol,dt,coordMin,step)
+ !! The force to be computed
+ real(mk), dimension(dime),intent(inout) :: force
+ !! vorticity fields, intent(in)
+ real(mk), dimension(:,:,:,:,:),pointer :: vort
+ !! Indicator function of the box
+ integer, dimension(:,:), pointer :: chi
+ !! Element of volume
+ real(mk),intent(in)::dvol
+ !> Time step
+ real(mk),intent(in)::dt
+ !! Coordinates of the lowest point in the domain
+ real(mk),dimension(dime),intent(in):: coordMin
+ !! mesh step sizes
+ real(mk),dimension(dime),intent(in)::step
+
+ ! coordinates of the current point
+ real(mk),dimension(dime) :: coords,int1
+ ! local indices
+ integer :: i,j,k,ind
+ real(mk)::fact
+ fact = -dvol/((dime-1)*dt)
+ int1=0.0
+ !! For all points in the box ...
+ do ind=1,size(chi,2)
+ i=chi(1,ind)
+ j=chi(2,ind)
+ k=chi(3,ind)
+ ! coordinates of the current point
+ coords = coordMin + (chi(:,ind)-1)*step
+ !! part1 of the force
+ int1=int1+cross_prod(coords,vort(:,i,j,k,nsublist))
+ end do
+ force = force + fact*(int1-bufferForce)
+ bufferForce = int1 ! Save for next time step ...
+ end subroutine integrateOnBox
+
+ !> Compute integrals on surface to calculate forces acting on the body.
+ !! See (2.1) of Noca 1999 or (52) of Plouhmans 2002
+ !! Integrals on the sphere are neglected.
+ subroutine integrateOnSurface(force,velo,vort,chi,NormalVec,direction,nu,dsurf,coordMin,step)
+ !! The force to be computed
+ real(mk), dimension(dime),intent(inout) :: force
+ !! velocity and vorticity fields, intent(in)
+ real(mk), dimension(:,:,:,:,:),pointer :: velo,vort
+ !! Indicator function of the considered face, intent(in)
+ integer, dimension(:,:), pointer :: chi
+ !! Normal to the considered face (dir : to the outside of the volume)
+ real(mk), dimension(dime),intent(in) :: NormalVec
+ !! index of the non-null coordinate in normal, must be c_X,c_Y or c_Z
+ integer,intent(in) :: direction
+ !! viscosity
+ real(mk),intent(in)::nu
+ !! Element of surface
+ real(mk),intent(in)::dsurf
+ !! Coordinates of the lowest point in the domain
+ real(mk),dimension(dime),intent(in):: coordMin
+ !! mesh step sizes
+ real(mk),dimension(dime),intent(in)::step
+
+ !! Some local values ...
+ real(mk) :: u_u,n_u,n_w,fact
+ integer :: i,j,k,ind
+ !! local coordinates
+ real(mk), dimension(dime) :: coords
+ real(mk), dimension(dime) :: int1,int2,nDivT,diff_dir,buffer
+
+ fact = 1./(dime-1)
+ ! For each point of the current plane ...
+ int1=0.0
+ int2=0.0
+ diff_dir=0.0
+ do ind=1,size(chi,2)
+ i=chi(1,ind)
+ j=chi(2,ind)
+ k=chi(3,ind)
+ !! part1 = 1/2(velocity.velocity)n - (n.velocity)velocity - 1/(dime-1)((n.velocity)(coord X vorticity) + (n.vorticity)(coord X velocity)
+ ! 0.5*velocity.velocity
+ u_u=dot_product(velo(:,i,j,k,nsublist),velo(:,i,j,k,nsublist))
+ ! normal.velocity
+ n_u=dot_product(velo(:,i,j,k,nsublist),NormalVec(:))
+ ! normal.vorticity
+ n_w=dot_product(vort(:,i,j,k,nsublist),NormalVec(:))
+ ! coordinates of the current point
+ coords = coordMin + (chi(:,ind)-1)*step
+ !! part1 of the force
+ int1=int1+0.5*u_u*NormalVec(:)-n_u*velo(:,i,j,k,nsublist)&
+ - fact*n_u*cross_prod(coords,vort(:,i,j,k,nsublist))&
+ + fact*n_w*cross_prod(coords,velo(:,i,j,k,nsublist))
+
+ !! part 2 of the force, the one concerning T = nu(nabla u + nabla uT)
+ !! Considering that the box is a parallepiped, each normal is equal to something like 1 0 0
+ !! and the integral simplifies in :
+ !! n.T = nabla velocity_dir + d/ddir velocity, dir being the dir of the normal,
+ !! n X nabla.T = function(laplacian of the velocity components)
+ nDivT = 0.0 ! n X nabla.T
+
+ if(direction==c_X) then ! face = Down or Up, d/dx
+ diff_dir = diffX(velo,i,j,k,step(direction),nsublist)
+ nDivT(2) = -laplacian(velo,c_Z,i,j,k,step,nsublist) ! Laplacian of velocity_y
+ nDivT(3) = laplacian(velo,c_Y,i,j,k,step,nsublist) ! Laplacian of velocity_z
+ else if(direction==c_Y) then ! face = East or West, d/dy
+ diff_dir = diffY(velo,i,j,k,step(direction),nsublist)
+ nDivT(3)=-laplacian(velo,c_X,i,j,k,step,nsublist) ! Laplacian of velocity_x
+ nDivT(1)=laplacian(velo,c_Z,i,j,k,step,nsublist) ! Laplacian of velocity_z
+ else if(direction==c_Z) then ! face = North or South, d/dz
+ diff_dir = diffZ(velo,i,j,k,step(direction),nsublist)
+ nDivT(2)=laplacian(velo,c_X,i,j,k,step,nsublist) ! Laplacian of velocity_x
+ nDivT(1)=-laplacian(velo,c_Y,i,j,k,step,nsublist) ! Laplacian of velocity_y
+ end if
+ buffer=nabla(velo,direction,i,j,k,step,nsublist) + diff_dir + fact*cross_prod(coords,nDivT)
+ buffer=NormalVec(direction)*nu*buffer
+ int2=int2+buffer
+
+ end do
+
+ ! Product with element of surface and sum to the total (input) force
+ force = force+(int1+int2)*dsurf
+ end subroutine integrateOnSurface
+
+ !> get memory allocated for indicator sets
+ function getMemoryForIndicators()
+ real(mk) :: getMemoryForIndicators
+
+ getMemoryForIndicators = sizeof(chi_boundary)+sizeof(chi_sphere)+sizeof(chi_box)+sizeof(chi_north)&
+ + sizeof(chi_west)+sizeof(chi_east)+sizeof(chi_south)+sizeof(chi_up)+sizeof(chi_down)
+ getMemoryForIndicators = getMemoryForIndicators*1e-6
+ if(verbose) then
+ write(*,'(a,i3,a,f10.4,a)') &
+ '[',rank,'] memory used for indicator sets:', getMemoryForIndicators, ' MB.'
+ end if
+
+ end function getMemoryForIndicators
+
+end module SetsIndicators
diff --git a/HySoP/src/Unstable/TestFunctions.f90 b/HySoP/src/Unstable/TestFunctions.f90
new file mode 100755
index 0000000000000000000000000000000000000000..2013ff5277d0aa45c8a8a6e94a7f3c7f69bd6554
--- /dev/null
+++ b/HySoP/src/Unstable/TestFunctions.f90
@@ -0,0 +1,380 @@
+!> Functions used to compute fields values on the grid, for specific pre-defined cases.
+module testsFunctions
+
+ use client_data
+ implicit none
+
+ real(mk) :: xref
+ integer :: np
+contains
+
+ !> Computes the analytical values for stream function, velocity and vorticity such that
+ !> \f{eqnarray*}{ rhs_{ex} &=& -\omega_{ex} = \Delta\psi_{ex} \\ vel_{ex} &=& \nabla \times \psi_{ex} \f}
+ !> \f{eqnarray*}{\nabla.\psi_{ex} &=& \nabla.\omega_{ex} = \nabla.vel_{ex} = 0.0 \\\nabla\times vel_{ex} &=& \omega_{ex} \f}
+ !> (see maple file)
+ subroutine poisson_analytic(resolution,step,coordMin,rhs_ex,vel_ex,psi_ex)
+
+ !> the local resolution
+ integer, dimension(dime),intent(in) :: resolution
+ !> size of mesh step in each dir
+ real(mk), dimension(dime),intent(in) :: step
+ !> Coordinates of the local minimum point
+ real(mk),dimension(dime),intent(in) :: coordMin
+ ! rhs function values on the grid (i.e. -omega_ex)
+ real(mk), dimension(:,:,:,:), pointer :: rhs_ex
+ ! velocity function values on the grid
+ real(mk), dimension(:,:,:,:), pointer :: vel_ex
+ ! Stream function values on the grid
+ real(mk), dimension(:,:,:,:), pointer :: psi_ex
+
+
+ real(mk) :: x,y,z,cx,cy,cz,c2x,c2y,c2z,sx,sy,sz,s2x,s2y,s2z
+ integer :: i,j,k
+ real(mk) :: pi
+
+ pi = 4.0*atan(1.0_mk)
+
+ do k=1,resolution(c_Z)
+ z = coordMin(c_Z) + (k-1)*step(c_Z)
+ cz=cos(pi*z)
+ c2z=cos(2.*pi*z)
+ sz=sin(pi*z)
+ s2z=sin(2.*pi*z)
+ do j=1,resolution(c_Y)
+ y = coordMin(c_Y) + (j-1)*step(c_Y)
+ cy=cos(pi*y)
+ c2y=cos(2.*pi*y)
+ sy=sin(pi*y)
+ s2y=sin(2.*pi*y)
+ do i=1,resolution(c_X)
+ x = coordMin(c_X) + (i-1)*step(c_X)
+ cx=cos(pi*x)
+ c2x=cos(2.*pi*x)
+ sx=sin(pi*x)
+ s2x=sin(2.*pi*x)
+
+ rhs_ex(1,i,j,k) = 8.*s2y*pi**2*s2z
+ rhs_ex(2,i,j,k) = 8.*s2x*pi**2*s2z
+ rhs_ex(3,i,j,k)= 8.*s2x*pi**2*s2y
+
+ vel_ex(1,i,j,k) = 2.*s2x*pi*(c2y - c2z)
+ vel_ex(2,i,j,k) = 2.*s2y*pi*(c2z - c2x)
+ vel_ex(3,i,j,k) = 2.*s2z*pi*(c2x - c2y)
+
+ psi_ex(1,i,j,k) = sy*sz
+ psi_ex(2,i,j,k) = sx*sz
+ psi_ex(3,i,j,k) = sx*sy
+
+ end do
+ end do
+ end do
+ end subroutine poisson_analytic
+
+ !> Init vorticity field on a grid, such that :
+ !> \f$ \omega(x,y,z) = \left[\begin{array}{c} 0 \\ -3z/(Lz^2) \\ 0 \end{array}\right]\f$
+ subroutine init_vorticity(vorticity,resolution,step,coordMin,lower,upper)
+
+ !> vorticity field
+ real(mk), dimension(:,:,:,:), pointer :: vorticity
+ !> the local mesh resolution
+ integer,dimension(dime),intent(in) :: resolution
+ !> size of mesh step in each dir
+ real(mk), dimension(dime),intent(in) :: step
+ !> Coordinates of the minimal point of the local domain
+ real(mk),dimension(dime),intent(in) :: coordMin
+ !> boundaries of the domain
+ real(mk),dimension(dime),intent(in):: upper,lower
+ integer :: i,j,k
+ real(mk) :: x,z,physicalDomainSize_Z
+ real(mk) :: coef
+
+ physicalDomainSize_Z = (upper(c_Z)- lower(c_Z))/2.
+ vorticity = 0.0
+ coef = -3./(physicalDomainSize_Z)**2
+
+ do k=1,resolution(c_Z)
+ z = coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)
+ !y = coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)
+ x = coordMin(c_X) + (i-1)*step(c_X)
+ !if( (z < upper(c_Z)).and.(z>lower(c_Z))) then
+ vorticity(c_Y,i,j,k) = cos(2.*pi*z)!)coef*z
+ !endif
+ end do
+ end do
+ end do
+
+
+ end subroutine init_vorticity
+
+ !> Computes the analytical values for stream function, velocity and vorticity such that
+ !> \f{eqnarray*}{ rhs_{ex} &=& -\omega_{ex} = \Delta\psi_{ex} \\ vel_{ex} &=& \nabla \times \psi_{ex} \f}
+ !> \f{eqnarray*}{\nabla.\psi_{ex} &=& \nabla.\omega_{ex} = \nabla.vel_{ex} = 0.0 \\\nabla\times vel_{ex} &=& \omega_{ex} \f}
+ !> (see maple file)
+ subroutine rhs_analytic(resolution,step,coordMin,rhs_ex,velocity,vorticity,nu)
+ !> the local mesh resolution
+ integer,dimension(dime),intent(in) :: resolution
+ !> size of mesh step in each dir
+ real(mk), dimension(dime),intent(in) :: step
+ !> Coordinates of the minimal point of the local domain
+ real(mk),dimension(dime),intent(in) :: coordMin
+ ! rhs function values on the grid (i.e. -omega_ex)
+ real(mk), dimension(:,:,:,:), pointer :: rhs_ex,velocity,vorticity
+ !> viscosity
+ real(mk),intent(in) :: nu
+
+ real(mk) :: x,y,z,cx,cy,cz,c2x,c2y,c2z,sx,sy,sz,s2x,s2y,s2z
+ integer :: i,j,k
+
+ do k=1,resolution(c_Z)
+ z = coordMin(c_Z) + (k-1)*step(c_Z)
+ cz=cos(pi*z)
+ c2z=cos(2.*pi*z)
+ sz=sin(pi*z)
+ s2z=sin(2.*pi*z)
+ do j=1,resolution(c_Y)
+ y = coordMin(c_Y) + (j-1)*step(c_Y)
+ cy=cos(pi*y)
+ c2y=cos(2.*pi*y)
+ sy=sin(pi*y)
+ s2y=sin(2.*pi*y)
+ do i=1,resolution(c_X)
+ x = coordMin(c_X) + (i-1)*step(c_X)
+ cx=cos(pi*x)
+ c2x=cos(2.*pi*x)
+ sx=sin(pi*x)
+ s2x=sin(2.*pi*x)
+
+ rhs_ex(1,i,j,k) = 32.*s2y*pi**4*s2z*(-2.*nu+c2x*c2y-c2x*c2z)
+ rhs_ex(2,i,j,k) = -32.*s2x*pi**4*s2z*(2.*nu-c2y*c2z+c2x*c2y)
+ rhs_ex(3,i,j,k) = 32.*s2x*pi**4*s2y*(-2.*nu+c2x*c2z-c2z*c2y)
+
+ vorticity(1,i,j,k) = 8.*s2y*pi**2*s2z
+ vorticity(2,i,j,k) = 8.*s2x*pi**2*s2z
+ vorticity(3,i,j,k)= 8.*s2x*pi**2*s2y
+
+ velocity(1,i,j,k) = 2.*s2x*pi*(c2y - c2z)
+ velocity(2,i,j,k) = 2.*s2y*pi*(c2z - c2x)
+ velocity(3,i,j,k) = 2.*s2z*pi*(c2x - c2y)
+
+
+ end do
+ end do
+ end do
+ end subroutine rhs_analytic
+ !> Test purpose function,
+ !> computes \f$ \omega(x,y,z) = \left[\begin{array}{c} 0 \\ 0 \\ 0.1 \end{array}\right]\f$
+ !> and \f$ velocity(x,y,z) = \left[\begin{array}{c} 0 \\ 0 \\ 2.0 \end{array}\right]\f$
+ subroutine test_particles(vorticity,velocity,resolution,step,coordMin)
+
+ !> vorticity field
+ real(mk), dimension(:,:,:,:), pointer :: vorticity ,velocity
+ !> the local resolution
+ integer, dimension(dime),intent(in) :: resolution
+ !> size of mesh step in each dir
+ real(mk), dimension(dime),intent(in) :: step
+ !> Coordinates of the local minimum point
+ real(mk),dimension(dime),intent(in) :: coordMin
+
+ integer :: i,j,k,l
+ real(mk) :: pi,x,y,z
+
+ pi = 4.0*atan(1.0_mk)
+ vorticity = 0.
+ velocity = 0.
+ do k=1,resolution(c_Z)
+ z = coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)
+ y = coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)
+ x = coordMin(c_X) + (i-1)*step(c_X)
+ if( (x .eq.10*step(c_X)).and.(y.eq.0).and.(z.eq.xref)) then
+ do l=1,np
+ vorticity(3,i,j,k+l-1) = 0.1;
+ velocity(3,i,j,k+l-1) = 2.0
+ enddo
+ endif
+ end do
+ end do
+ end do
+ xref = xref + step(c_Z)
+ !np = np +1
+ end subroutine test_particles
+
+ !> Test purpose function,
+ !> computes \f$ \omega(x,y,z) = \left[\begin{array}{c} cos(x) \\ cos(x) \\ cos(x) \end{array}\right]\f$
+ subroutine test_vorticity(vorticity,resolution,step,coordMin,lower,upper)
+ ! vorticity field
+ real(mk), dimension(:,:,:,:), pointer :: vorticity
+ !> the local resolution
+ integer, dimension(dime),intent(in) :: resolution
+ !> size of mesh step in each dir
+ real(mk), dimension(dime),intent(in) :: step
+ !> Coordinates of the local minimum point
+ real(mk),dimension(dime),intent(in) :: coordMin
+ !> Boundaries coordinates
+ real(mk),dimension(dime),intent(in):: upper, lower
+
+ integer :: i,j,k
+ real(mk) :: pi,x,y,z,physicalDomainSize_Z
+ real(mk) :: coef
+
+ physicalDomainSize_Z = (upper(3)- lower(3))/2.
+ pi = 4.0*atan(1.0_mk)
+ vorticity = 0.0
+ coef = -3./(physicalDomainSize_Z)**2
+ do k=1,resolution(c_Z)
+ z = coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)
+ y = coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)
+ x = coordMin(c_X) + (i-1)*step(c_X)
+ vorticity(:,i,j,k) = cos(x)
+ end do
+ end do
+ end do
+ end subroutine test_vorticity
+
+
+ !> Compute flow through x = xmin surface, for the following stream function :
+ !> \f$ \psi(x,y,z) = \left[\begin{array}{c} 0 \\-U_{inf}z(1 - \frac{R^2}{z^2+x^2}) \\ 0 \end{array}\right] \f$
+ !> i.e.
+ !> \f[ flowRate_{theo} = \left[ -U_{inf}length_y(z - \frac{R^2z}{z^2+x^2})\right]_{lower_z}^{upper_z}\f]
+ function requiredFlowRate3D(radius,length,lower,upper,uinf)
+
+ !> sphere radius
+ real(mk),intent(in) :: radius
+ !> domain dimensions
+ real(mk),dimension(dime),intent(in) :: length
+ !> physical domain lower point
+ real(mk),dimension(dime),intent(in)::lower
+ !> physical domain upper point
+ real(mk),dimension(dime),intent(in)::upper
+ !> velocity inf
+ real(mk),intent(in) :: uinf
+ !> required flow rate
+ real(mk) :: requiredFlowRate3D
+
+ real(mk) :: dom
+ ! position of the surface for flow rate computation
+ real(mk)::xPos
+
+ xPos = lower(c_X)
+ dom = upper(c_Z)**2+xPos**2
+ if(abs(dom) < epsilon(dom)) then ! if dom == 0
+ requiredFlowRate3D = upper(c_Z)
+ else
+ requiredFlowRate3D = upper(c_Z)*(1.-radius**2/dom)
+ end if
+ dom = lower(c_Z)**2+xPos**2
+ if(abs(dom) < epsilon(dom)) then
+ requiredFlowRate3D = requiredFlowRate3D - lower(c_Z)
+ else
+ requiredFlowRate3D = requiredFlowRate3D - lower(c_Z)*(1. - radius**2/dom)
+ end if
+ requiredFlowRate3D = requiredFlowRate3D * uinf *length(c_Y)
+ return
+ end function requiredFlowRate3D
+
+ !> Compute flow through x = xmin surface, for the following stream function :
+ !> \f$ \psi(x,y,z) = \left[\begin{array}{c} 0 \\-U_{inf}z(1 - \frac{R^2}{z^2+x^2}) \\ 0 \end{array}\right] \f$
+ !> i.e.
+ !> \f[ flowRate_{theo} = \left[ -U_{inf}length_y(z - \frac{R^2z}{z^2+x^2})\right]_{lower_z}^{upper_z}\f]
+ function requiredFlowRate2D(radius,lower,upper,uinf)
+
+ !> sphere radius
+ real(mk),intent(in) :: radius
+ !> physical domain lower point
+ real(mk),dimension(dime),intent(in)::lower
+ !> physical domain upper point
+ real(mk),dimension(dime),intent(in)::upper
+ !> velocity inf
+ real(mk),intent(in) :: uinf
+ !> required flow rate
+ real(mk) :: requiredFlowRate2D
+
+ real(mk) :: dom
+ ! position of the surface for flow rate computation
+ real(mk)::xPos
+
+ xPos = lower(c_X)
+ dom = upper(c_Y)**2+xPos**2
+ if(abs(dom) < epsilon(dom)) then ! if dom == 0
+ requiredFlowRate2D = upper(c_Y)
+ else
+ requiredFlowRate2D = upper(c_Y)*(1.-radius**2/dom)
+ end if
+ dom = lower(c_Y)**2+xPos**2
+ if(abs(dom) < epsilon(dom)) then
+ requiredFlowRate2D = requiredFlowRate2D - lower(c_Y)
+ else
+ requiredFlowRate2D = requiredFlowRate2D - lower(c_Y)*(1. - radius**2/dom)
+ end if
+ requiredFlowRate2D = requiredFlowRate2D * uinf
+ return
+ end function requiredFlowRate2D
+
+
+ subroutine Gaussian2D(field,resolution,step,coordMin,center)
+
+ !> Field initialized with a Gaussian
+ real(mk), dimension(:,:,:), pointer :: field
+ !> Space step
+ real(mk), dimension(dime) :: step
+ !> local resolution
+ integer, dimension(dime) :: resolution
+ !> Coordinates of the lowest point in the current subdomain
+ real(mk),dimension(dime),intent(in) :: coordMin
+ !>
+ real(mk), dimension(dime),intent(in) :: center
+
+ real(mk), parameter :: sigma = 0.2
+ real(mk) :: expo
+ real(mk),dimension(dime) :: coord
+ integer :: i,j
+
+ field = 0.0
+ do j = 1,resolution(c_Y)
+ coord(c_Y) = coordMin(c_Y)+(j-1)*step(c_Y)-center(c_Y)
+ do i = 1, resolution(c_X)
+ coord(c_X) = coordMin(c_X) + (i-1)*step(c_X)-center(c_X)
+ expo=dot_product(coord,coord)*0.5/sigma**2
+ field(i,j,:) = exp(-expo)
+ end do
+ end do
+
+ end subroutine Gaussian2D
+
+ subroutine Gaussian1D(field,resolution,step,coordMin,dir,shift)
+
+ !> Field initialized with a Gaussian
+ real(mk), dimension(:,:,:), pointer :: field
+ !> Space step
+ real(mk), dimension(dime) :: step
+ !> local resolution
+ integer, dimension(dime) :: resolution
+ !> Coordinates of the lowest point in the current subdomain
+ real(mk),dimension(dime),intent(in) :: coordMin
+ !>
+ real(mk), intent(in) :: shift
+ !> Advection direction
+ integer, intent(in) :: dir
+
+ real(mk), parameter :: sigma = 0.2
+ real(mk) :: coord,coeff
+ integer :: i
+
+ !coord(c_Y) = coordMin(c_Y) + (j-1)*step(c_Y)
+ coeff = 1./(sigma*sqrt(2.*pi))
+ print * ,"shift",shift
+ field = 0.
+ do i = 1, resolution(dir)
+ coord = coordMin(dir) + (i-1)*step(dir)-shift
+ field(i,:,1) = coeff*exp(-0.5*(coord/sigma)**2.)
+ end do
+
+ end subroutine Gaussian1D
+
+
+end module testsFunctions
diff --git a/HySoP/src/Unstable/callPPM.f90 b/HySoP/src/Unstable/callPPM.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d934225342b1f5442b94bc361e756c138a18ae01
--- /dev/null
+++ b/HySoP/src/Unstable/callPPM.f90
@@ -0,0 +1,98 @@
+!> temp module to call and test ppm functions.
+module testPPM
+
+ !-------------------------------------------------------------------------
+ ! Modules
+ !-------------------------------------------------------------------------
+!!$ USE ppm_module_map
+!!$ USE ppm_module_topo
+!!$ USE ppm_module_loadbal
+!!$ USE ppm_module_neighlist
+!!$ USE ppm_module_ode
+!!$ USE ppm_module_user_util
+!!$ USE pse_global
+!!$ USE pse_module_io
+!!$ USE pse_module_comp
+
+ use ppm_module_init
+ use ppm_module_substart
+ use ppm_module_substop
+ use ppm_module_finalize
+ use ppm_module_data
+ use mpi
+
+ implicit none
+
+contains
+
+ subroutine mult(A,x,sizeA)
+ real, dimension(:) :: A
+ real :: x
+ integer :: sizeA,j
+
+ real*8, dimension(sizeA) :: B
+
+ x = 3
+ print *, "otot"
+ print *, A(1)
+ print *, "titi"
+
+ do j=1,sizeA
+ B(j) =j
+ !! do i=1,sizeA
+ !! print *, A(i,j)
+!!$ A(i,j) = x*A(i,j)
+ !!print *, A(j)
+ !!print *,'toto', B(j)
+ !!end do
+ end do
+ end subroutine mult
+
+ subroutine init()
+
+ real(8) :: t0
+ integer :: info,size
+ integer :: ndim, tolexp, comm, debug, ppm_log_unit
+ integer, parameter :: MK = KIND(1.0D0)
+
+ ndim = 3
+ tolexp = -15
+ comm = MPI_COMM_WORLD
+ debug = 2
+ ppm_log_unit = 99
+
+ call MPI_Init(info)
+ if(info.ne.0) then
+ write(*,*) 'FAILED TO INITIALIZE MPI. ABORTING!'
+ end if
+ call MPI_COMM_SIZE(comm,size,info)
+
+ ! PPM init.
+ !! This will:
+ !! - init the stdout, stderr, stdlog outputs
+ !! - check if MPI has been properly initialized
+ !! - fill comm, ppm_rank, ppm_nb_procs ... and MPI/ppm related values
+ !! - check and set dimension of the problem, precision and tolerance
+ !! - set MPI_PREC --> ppm_mpi_kind
+ !! - init proc speed array (ppm_proc_speed)
+ !! - reset topology counter
+ call ppm_init(ndim,MK,tolexp,comm,debug,info,ppm_log_unit,98,97)
+
+ print *, "debug ", debug, " module debug", ppm_debug
+
+ !! Display ...
+ call substart('testPPM',t0,info)
+
+ !! Warning : display elapsed time since t0.
+ call substop ('testPPM', t0, info)
+
+ !! Finalize
+ !! - deallocate lots of arrays ...
+ !! - call ppm_mesh_finalize --> deallocate mesh structures
+ call ppm_finalize(info)
+
+ call MPI_FINALIZE(info)
+
+ end subroutine init
+end module testPPM
+
diff --git a/HySoP/src/interfaces/Fortran2Cpp/WrapC.hpp b/HySoP/src/interfaces/Fortran2Cpp/WrapC.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..919a18e57f3472bb172a7c885afb5e4aeb17c317
--- /dev/null
+++ b/HySoP/src/interfaces/Fortran2Cpp/WrapC.hpp
@@ -0,0 +1,10 @@
+#ifndef CWRAPPER_HPP
+#define CWRAPPER_HPP
+
+typedef struct {
+ int length;
+ double* elements;
+} C2FPtr;
+
+
+#endif
diff --git a/HySoP/src/interfaces/Fortran2Cpp/WrapFortran.f90 b/HySoP/src/interfaces/Fortran2Cpp/WrapFortran.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7748dd0c404c007f1d8f956006915e9fff560b1b
--- /dev/null
+++ b/HySoP/src/interfaces/Fortran2Cpp/WrapFortran.f90
@@ -0,0 +1,35 @@
+module WrapFort
+
+ use iso_c_binding
+
+ implicit none
+
+ public aliasF2C
+
+ real(kind=8) :: ref
+ integer, parameter :: real_kind = kind(ref)
+
+ !> A structure to bind C and fortran pointers
+ type, bind(C), public :: C2FPtr
+ integer (c_int) :: length
+ type (c_ptr) :: elements
+ end type C2FPtr
+
+ logical, parameter :: NDEBUG = .TRUE.
+
+contains
+
+ subroutine aliasF2C(vectorC, vectorF, length)
+ type(c_ptr),intent(inout) :: vectorC
+ integer(c_int), intent(out) :: length
+ real(kind=real_kind), pointer, dimension(:) :: vectorF
+
+ if(.not.associated(vectorF) ) then
+ stop 'Error, input Fortran vector is not associated'
+ end if
+ length = size(vectorF)
+ vectorC = c_loc(vectorF(1))
+
+ end subroutine aliasF2C
+
+end module WrapFort
diff --git a/HySoP/src/interfaces/ppm/ppm_wrapper.hpp b/HySoP/src/interfaces/ppm/ppm_wrapper.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..85181449f73f2baea3acbceb8356d3beba5a1728
--- /dev/null
+++ b/HySoP/src/interfaces/ppm/ppm_wrapper.hpp
@@ -0,0 +1,104 @@
+/** \file ppm_wrapper.hpp Interfaces to ppm (fortran) routines
+ */
+#ifndef PPMWRAPPER_HPP
+#define PPMWRAPPER_HPP
+#include"F2CMangle.hpp"
+#include<mpi.h>
+#include <cstring>
+
+/** Namespace for ppm functions and subroutines */
+
+namespace PPM
+{
+
+ extern "C" {
+
+ //F2C_GLOBAL(pass,PASS);
+ // Init and close ppm
+ void F2C_MODULE(ppm_module_init,ppm_init, PPM_MODULE_INIT,PPM_INIT)(int*, int*,int*,int*,int*,int*,int*,int*,int*);
+ void F2C_MODULE(ppm_module_finalize, ppm_finalize,PPM_MODULE_FINALIZE,PPM_FINALIZE)(int&);
+ // Display functions
+ void F2C_MODULE(charfunctions, start, CHARFUNCTIONS, START)(double*,int*,char*,int );
+ void F2C_MODULE(charfunctions, stop, CHARFUNCTIONS, stop)(double*,int*,char*,int );
+
+ void F2C_MODULE(testppm,mult,TESTPPM,MULT)(double*,double*,int*);
+
+ // Topologies
+ // void F2C_MODULE(ppm_module_mktopo, ppm_mktopo, PPM_MODULE_MKTOPO,PPM_MKTOPO)(int*, double*, int*,
+
+ void F2C_MODULE(modtest, cas1, MODTEST,CAS1)(double*);
+ void F2C_MODULE(modtest, cas2, MODTEST,CAS2)(double*);
+ void F2C_MODULE(modtest, cas3, MODTEST,CAS3)(double*);
+ void F2C_MODULE(modtest, cas4, MODTEST,CAS4)(double*);
+ void F2C_MODULE(modtest, cas5, MODTEST,CAS5)(double*);
+ void F2C_MODULE(modtest, cas6, MODTEST,CAS6)(double*);
+ void F2C_MODULE(modtest, application3, MODTEST,APPLICATION3)();
+ // int F2C_MODULE(ppm_module_data,ppm_debug, PPM_MODULE_DATA,PPM_DEBUG);
+ }
+
+
+ /** A static class to call wrapped ppm functions */
+ class wrapper
+ {
+
+ static int _info;
+
+ public :
+
+ /** PPM initialization
+ \param problem dimension
+ \param precision for real numbers
+ \param exp tolerance
+ \param MPI comm
+ \param debug mode value
+ \param error status
+ \param log unit value for io
+ \param stderr unit value
+ \param stdout unit value
+ */
+ static void init(int ndim, int MK,int tolexp, MPI::Intracomm& comm, int debug, int* info, int ppm_log_unit, int err, int out)
+ {
+ MPI_Fint Fcomm = MPI_Comm_c2f(comm);
+ F2C_MODULE(ppm_module_init,ppm_init, PPM_MODULE_INIT,PPM_INIT)(&ndim,&MK,&tolexp,&Fcomm,&debug,info,&ppm_log_unit,&err,&out);
+ }
+
+ /** Terminates ppm library
+ \param[in,out] error status
+ */
+ static void finalize(int& info)
+ {
+ F2C_MODULE(ppm_module_finalize, ppm_finalize,PPM_MODULE_FINALIZE,PPM_FINALIZE)(info);
+ }
+
+ /** Wrapper to ppm substart function
+ @param[in] caller name
+ @param[in,out] cpu time when this function is called
+ @param[in] error status
+ */
+ static void substart(std::string& msg, double* t0, int* info)
+ {
+ size_t size = msg.size()+1;
+ char * msgF = new char[size];
+ strncpy(msgF, msg.c_str(),size);
+ F2C_MODULE(charfunctions, start, CHARFUNCTIONS, START)(t0,info,msgF,strlen(msgF));
+ }
+
+ /** Wrapper to ppm substopt function
+ @param[in] caller name
+ @param[in] cpu time when substart for this function has been called
+ @param[in] error status
+ */
+ static void substop(std::string& msg, double* t0, int* info)
+ {
+ size_t size = msg.size()+1;
+ char * msgF = new char[size];
+ strncpy(msgF, msg.c_str(),size);
+ F2C_MODULE(charfunctions, stop, CHARFUNCTIONS, STOP)(t0,info,msgF,strlen(msgF));
+ }
+
+ };
+
+}
+
+
+#endif
diff --git a/HySoP/src/interfaces/ppm/wrap_ppm_topologies.f95 b/HySoP/src/interfaces/ppm/wrap_ppm_topologies.f95
new file mode 100644
index 0000000000000000000000000000000000000000..a13e7dc1f34cd0d92762a7a64108f51a825f9472
--- /dev/null
+++ b/HySoP/src/interfaces/ppm/wrap_ppm_topologies.f95
@@ -0,0 +1,54 @@
+!> Fortran 2003 interface to ppm routines related to topologies
+module wrap_ppm_topologies
+
+ use ppm_module_mktopo
+ use WrapFort
+ use ppm_module_data
+
+ implicit none
+
+contains
+
+ !> Purely geometry-based decompositions
+ subroutine create_topology_geom(dimPb, topoid, decomp, minPhys, maxPhys, bc, ghostsize) bind(C, name='createTopoG')
+
+ integer(kind=c_int), intent(in) :: dimPb
+ integer(kind=c_int), intent(inout) :: topoid
+ integer(kind=c_int), intent(inout) :: decomp
+ !integer(kind=c_int), intent(in) :: assig
+ type(c_Ptr), intent(in), VALUE :: minPhys
+ type(c_Ptr), intent(in), VALUE :: maxPhys
+ type(c_Ptr), intent(in), VALUE :: bc
+ real(kind=real_kind), intent(in) :: ghostsize ! ghostsize is a real in ppm subroutine ... strange ...
+! type(c_ptr), intent(inout) :: costPerProc
+
+
+ ! Local vars
+ integer :: info
+ ! integer :: nbProcs = 3 ! TODO : input arg
+ integer :: assig = ppm_param_assign_internal
+ real(kind=real_kind), pointer, dimension(:) :: cost => NULL()
+ real(kind=real_kind), pointer, dimension(:) ::min_phys => NULL(), max_phys => NULL()
+ integer, pointer, dimension(:) :: bcdef => NULL()
+ ! Wrap C pointers
+ call c_f_pointer (minPhys, min_phys, (/dimPb/))
+ call c_f_pointer(maxPhys, max_phys, (/dimPb/))
+ call c_f_pointer(bc, bcdef, (/dimPb/))
+ decomp = ppm_param_decomp_cuboid
+
+ ! If cost is already allocated
+ ! if(c_associated(costPerProc)) then
+ ! call c_f_pointer(costPerProc, cost, (/nbProcs/))
+ ! end if
+
+ ! We skip optional vars for the moment ...
+ call ppm_topo_mkgeom_d(topoid, decomp,assig, min_phys, max_phys, bcdef, ghostsize, cost, info)
+
+ !call aliasF2C(costPerProc, cost, nbProcs)
+
+ print *, "topoid ", topoid
+
+ end subroutine create_topology_geom
+
+
+end module wrap_ppm_topologies
diff --git a/HySoP/src/ppmInterface/CMakeLists.txt b/HySoP/src/ppmInterface/CMakeLists.txt
new file mode 100755
index 0000000000000000000000000000000000000000..158812ec4b61030239adea8df81e7201610cbcfa
--- /dev/null
+++ b/HySoP/src/ppmInterface/CMakeLists.txt
@@ -0,0 +1,21 @@
+
+find_package(PPMCore 1.2 REQUIRED)
+include_directories(${PPMCore_INCLUDE_DIRS})
+set(LIBS ${LIBS} ${PPMCore_LIBRARY})
+if(VERBOSE_MODE)
+ message(STATUS "Found PPM version ${PPMCore_VERSION}: ${PPMCore_LIBRARY}")
+ message(STATUS "PPM headers location: ${PPMCore_INCLUDE_DIRS}")
+endif(VERBOSE_MODE)
+
+# --- PPM Numerics ---
+if(WITH_PPMNumerics)
+ find_package(PPMNumerics 1.2 REQUIRED)
+ include_directories(${PPMNumerics_INCLUDE_DIRS})
+ set(LIBS ${LIBS} ${PPMNumerics_LIBRARY})
+ if(VERBOSE_MODE)
+ message(STATUS "Found PPMNumerics version ${PPMNUmerics_VERSION}: ${PPMNumerics_LIBRARY}")
+ message(STATUS "PPMNumerics header location: ${PPMNumerics_INCLUDE_DIRS}")
+ endif(VERBOSE_MODE)
+endif()
+
+
diff --git a/HySoP/src/ppmInterface/Fields.f90 b/HySoP/src/ppmInterface/Fields.f90
new file mode 100755
index 0000000000000000000000000000000000000000..31a7524274b1525743de1cb6ea8f676fc34fc71e
--- /dev/null
+++ b/HySoP/src/ppmInterface/Fields.f90
@@ -0,0 +1,143 @@
+!> Declaration, allocation of all the fields on the grid.
+module Fields
+
+ use client_data
+ use mpi
+ use PPMFields
+
+ implicit none
+
+ !> Velocity
+ real(mk), dimension(:,:,:,:), pointer :: velocity => NULL()
+ !> Vorticity
+ real(mk), dimension(:,:,:,:), pointer :: vorticity =>NULL()
+ !> Vorticity (a scalar in the 2D case)
+ real(mk), dimension(:,:,:), pointer :: vorticity2D =>NULL()
+ !> Stream function - Test purpose. Useless if ppm fft solver works as it is supposed to ...
+ ! real(mk), dimension(:,:,:,:,:), pointer :: stream_function =>NULL()
+ !> rhs of vorticity eq (i.e. stretch + diffusion terms)
+ real(mk), dimension(:,:,:,:), pointer :: rhs =>NULL()
+ real(mk), dimension(:,:,:), pointer :: gauss =>NULL()
+ !>
+ !real(mk), dimension(:,:,:,:,:), pointer :: vel_ex => NULL()
+ !> Scalar on the grid, test purpose for chi functions
+ real(mk),dimension(:,:,:),pointer::testFunc=>NULL()
+ !> Scalar on the grid
+ real(mk),dimension(:,:,:),pointer::scalar=>NULL()
+
+contains
+
+ !> Fields allocation.
+ !! Warning : ghostpoints must be included in field (i.e. size = "real size" + 2*number of ghostpoints)
+ subroutine initFields(resolution,ghostsize)
+
+ !> Required resolution for the fields (without ghosts)
+ integer, dimension(dime), intent(in) :: resolution
+ !> number of ghost points in each direction (ghost(c_X) = 2 means resolution(c_X)+ 4 points for the field)
+ integer, dimension(:),pointer:: ghostsize
+
+ integer::istat
+ ! Lower and upper bounds for fields
+ integer, dimension(dime) :: ldl, ldu
+ ! nsublist from ppm topo. Assumed to be equal to 1 see Topology.f90
+
+ ldl = 1 - ghostsize
+ ldu = resolution + ghostsize
+
+
+ if(dime==2) then
+ call initPPMFields2D(resolution,ghostsize)
+ velocity => PPMvelocity2D
+ vorticity2D => PPMvorticity2D
+ scalar => PPMscalar2D
+ allocate(gauss(ldl(c_X):ldu(c_X),ldl(c_Y):ldu(c_Y),1), stat = istat)
+ allocate(rhs(dime,ldl(c_X):ldu(c_X),ldl(c_Y):ldu(c_Y),1), stat = istat)
+
+ else if(dime == 3) then
+ call initPPMFields3D(resolution,ghostsize)
+ velocity => PPMvelocity3D(:,:,:,:,1)
+ vorticity => PPMvorticity3D(:,:,:,:,1)
+ rhs => PPMrhs3D(:,:,:,:,1)
+ allocate(gauss(ldl(c_X):ldu(c_X),ldl(c_Y):ldu(c_Y),ldl(c_Z):ldu(c_Z)), stat = istat)
+ end if
+
+ allocate(testFunc(resolution(c_X),resolution(c_Y),resolution(c_Z)))
+
+
+!!$ ! Velocity ...
+!!$ allocate(velocity(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist),stat = istat)
+!!$ if(istat.ne.0) stop 'Field allocation error for velocity'
+!!$ ! Vorticity
+!!$ allocate(vorticity(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+!!$ if(istat.ne.0) stop 'Field allocation error for vorticity'
+!!$ ! rhs
+!!$ allocate(rhs(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+
+!!$ if(istat.ne.0) stop 'Field allocation error for rhs'
+!!$
+!!$ !allocate(stream_function(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+!!$ !if(istat.ne.0) stop 'stream_function allocation error for rhs'
+
+!! allocate(testFunc(ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3)), stat = istat)
+ !! if(istat.ne.0) stop 'Field allocation error for testFunc'
+ ! Scalar
+ !allocate(scalar(ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+ !if(istat.ne.0) stop 'Field allocation error for scalar'
+ end subroutine initFields
+
+ !> compute the size of the memory used to save fields
+ function getMemoryUsedForFields()
+ real(mk) :: getMemoryUsedForFields
+ getMemoryUsedForFields = sizeof(velocity)+sizeof(vorticity)+sizeof(rhs)+sizeof(testfunc)+sizeof(scalar)
+ getMemoryUsedForFields = getMemoryUsedForFields*1.e-6
+ if(verbose) then
+ write(*,'(a,i3,a,f10.4,a)') &
+ '[',rank,'] Fields have been initialized. Memory used :', getMemoryUsedForFields, ' MB.'
+ end if
+ end function getMemoryUsedForFields
+
+ !> Shift the velocity x component according to a required flow rate
+ !> \f[ velocity_x = velocity_x + shift \f]
+ !> with
+ !> \f[shift = \frac{reqFlowRate-currentFlowRate}{S_x} \f]
+ !> \f$S_x\f$ being the surface where x=xmin (incoming flow)
+ subroutine shiftVelocityX(reqFlowRate,step,resolution,surf,coordMin,lower)
+ !> Required flow rate
+ real(mk), intent(in) :: reqFlowRate
+ !> Grid step
+ real(mk), dimension(dime), intent(in) :: step
+ !> local resolution
+ integer,dimension(dime),intent(in) :: resolution
+ !> Area of the surface for integration
+ real(mk) ,intent(in) :: surf
+ !> Coordinates of the minimal point of the current domain
+ real(mk),dimension(dime),intent(in) :: coordMin
+ !> lower bound of the physical domain
+ real(mk),dimension(dime),intent(in) :: lower
+
+ real(mk) :: localShift,globalShift
+ integer :: info
+ localShift = 0
+
+ ! We compute the current flow rate through surface x = xmin, for the x component of the velocity :
+ ! FlowRate = sum(surf x=xmin)( velocity(c_X) ) * step(c_Z)*step(c_Y)
+ ! And use this value to shift the velocity(c_X) to have :
+ ! RequiredFlowRate = FlowRate + Surf(x=xmin)*globalShift
+
+ ! Step 1 : compute flowRate
+ if(abs(coordMin(c_X)-lower(c_X)) <= 2.*epsilon(globalShift) ) then
+ ! Compute mean value of the velocity through a face ortho. to x dir.
+ ! Warning: ghost points must be excluded
+ localShift = sum(velocity(c_X,1,1:resolution(c_Y)-1,1:resolution(c_Z)-1))
+ end if
+ ! Step 2 : reduction over all mpi processus ...
+ call MPI_ALLReduce(localShift,globalShift,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,info)
+ ! Step 3 : set global shift
+ globalShift = (reqFlowRate-globalShift*step(c_Y)*step(c_Z))/surf
+
+ ! Step 4 : update velocity(c_X)
+ velocity(c_X,:,:,:) = velocity(c_X,:,:,:) + globalShift
+
+ end subroutine shiftVelocityX
+
+end module Fields
diff --git a/HySoP/src/ppmInterface/PPMFields.f90 b/HySoP/src/ppmInterface/PPMFields.f90
new file mode 100755
index 0000000000000000000000000000000000000000..bb2e45920c48844bfcb8f277e28196ce9b37aac5
--- /dev/null
+++ b/HySoP/src/ppmInterface/PPMFields.f90
@@ -0,0 +1,80 @@
+!> Declaration, allocation of all the fields on the grid.
+module PPMFields
+
+ use client_data
+ use client_topology, only: nsublist
+
+ implicit none
+
+ !> Velocity 3D (PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: PPMvelocity3D => NULL()
+ !> Velocity 2D (PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: PPMvelocity2D => NULL()
+ !> Vorticity 3D (PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: PPMvorticity3D => NULL()
+ !> Vorticity 2D (PPM-style storage)
+ real(mk), dimension(:,:,:), pointer :: PPMvorticity2D => NULL()
+ !> RHS 3D (PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: PPMrhs3D => NULL()
+ !> A Scalar on a 3D grid (PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: PPMscalar3D => NULL()
+ !> A Scalar on a 2D grid (PPM-style storage)
+ real(mk), dimension(:,:,:), pointer :: PPMscalar2D => NULL()
+
+contains
+
+ !> Fields allocation.
+ !! Warning : ghostpoints must be included in field (i.e. size = "real size" + 2*number of ghostpoints)
+ subroutine initPPMFields3D(resolution,ghostsize)
+
+ !> Required resolution for the fields (without ghosts)
+ integer, dimension(dime), intent(in) :: resolution
+ !> number of ghost points in each direction (ghost(c_X) = 2 means resolution(c_X)+ 4 points for the field)
+ integer, dimension(:),pointer:: ghostsize
+
+ integer::istat
+ ! Lower and upper bounds for fields
+ integer, dimension(dime) :: ldl, ldu
+ ! nsublist from ppm topo. Assumed to be equal to 1 see Topology.f90
+
+ ldl = 1 - ghostsize
+ ldu = resolution + ghostsize
+ ! Velocity ...
+ allocate(PPMvelocity3D(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist),stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for velocity (PPM)'
+ ! Vorticity
+ allocate(PPMvorticity3D(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for vorticity (PPM))'
+ ! rhs
+ allocate(PPMrhs3D(dime,ldl(1):ldu(1),ldl(2):ldu(2),ldl(3):ldu(3),nsublist), stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for rhs (PPM))'
+
+ end subroutine initPPMFields3D
+
+ subroutine initPPMFields2D(resolution,ghostsize)
+
+ !> Required resolution for the fields (without ghosts)
+ integer, dimension(dime), intent(in) :: resolution
+ !> number of ghost points in each direction (ghost(c_X) = 2 means resolution(c_X)+ 4 points for the field)
+ integer, dimension(:),pointer:: ghostsize
+
+ integer::istat
+ ! Lower and upper bounds for fields
+ integer, dimension(dime) :: ldl, ldu
+ ! nsublist from ppm topo. Assumed to be equal to 1 see Topology.f90
+
+ ldl = 1 - ghostsize
+ ldu = resolution + ghostsize
+ ! Velocity ...
+ allocate(PPMvelocity2D(dime,ldl(1):ldu(1),ldl(2):ldu(2),1),stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for velocity (PPM)'
+ ! Vorticity (a sacalar in 2D)
+ allocate(PPMvorticity2D(ldl(1):ldu(1),ldl(2):ldu(2),1), stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for vorticity (PPM))'
+ ! Scalar
+ allocate(PPMscalar2D(ldl(1):ldu(1),ldl(2):ldu(2),1), stat = istat)
+ if(istat.ne.0) stop 'Field allocation error for scalar (PPM))'
+
+ end subroutine initPPMFields2D
+
+end module PPMFields
diff --git a/HySoP/src/ppmInterface/Particles.f90 b/HySoP/src/ppmInterface/Particles.f90
new file mode 100755
index 0000000000000000000000000000000000000000..1b7b12b5fffc5b3a28eb5736e19076196b815ef3
--- /dev/null
+++ b/HySoP/src/ppmInterface/Particles.f90
@@ -0,0 +1,1445 @@
+!> Functions dealing with particles :
+!> - initialisation, creation
+!> - remesh and interpolation
+!> - integration (push)
+module Particles
+
+ use ppm_module_rmsh, only : ppm_rmsh_create_part,ppm_interp_m2p, ppm_interp_p2m !, ppm_rmsh_remesh
+ use ppm_module_map_field_ghost, only:ppm_map_field_ghost_get!, ppm_map_field_ghost_put
+ use ppm_module_map_field, only : ppm_map_field_push,ppm_map_field_send,ppm_map_field_pop
+ use ppm_module_impose_part_bc
+ use client_data
+ use ppm_module_data, only : ppm_param_rmsh_kernel_mp4
+ use ppm_module_map_part
+ use ppm_module_util_dbg
+
+ implicit none
+
+ private
+
+ public initNSSolver_particles,getMemoryUsedForParticles,ScalarSolver_particles,init_parts,&
+ countAndCreateParticles, countAndUpdateParticles,PPMupdateParticles3D, PPMupdateParticles2D,&
+ freeParticles,createParticlesEverywhere,npart,RK4_2D,Ppmremesh2d,RK2_2D,PPMupdateParticles2DScalar,&
+ RK2_2DScalar,PPMremesh2DScalar,remesh2D,createParticlesEverywhereScalar,RK4_2Dscalar
+
+ !> cutoff values (threshold for vorticity values for which particles are created)
+ real(mk), dimension(2) :: cutoff
+ !> Current number of particles
+ integer :: npart
+ !> Particles positions
+ real(mk), dimension(:,:), pointer :: xp=>NULL()
+ !> Particles strength (ie var carried by part, vorticity indeed)
+ real(mk), dimension(:,:), pointer :: omp=>NULL()
+ !> Particle velocities
+ real(mk), dimension(:,:), pointer :: velop=>NULL()
+ !> Particles RHS term
+ real(mk), dimension(:,:), pointer :: rhsp => NULL()
+ !> Particles scalar term
+ real(mk), dimension(:), pointer :: scalar_p => NULL()
+ !> Backup vector for RK schemes
+ real(mk), dimension(:,:), pointer :: buffer=>NULL(),buffer2=>NULL(),buffer3=>NULL()
+
+ !> Size of buffer, i.e. more or less number of particles at the previous time step
+ integer :: buffer_size
+ !> Kernel for remesh ...
+ integer :: kernel
+
+contains
+
+ subroutine ScalarSolver_particles(scalar,velocity,dt,topoid,meshid,ghostsize,resetpos,step,coordMin,resolution)
+
+ !> Vorticity field, on the grid
+ real(mk),dimension(:,:,:),pointer :: scalar
+ !> Velocity field, on the grid
+ real(mk),dimension(:,:,:,:),pointer :: velocity
+ !> Current time step
+ real(mk),intent(in) :: dt
+ !> Current topo id
+ integer, intent(in) :: topoid
+ !> Current mesh id
+ integer, intent(in) :: meshid
+ !> Number of ghost points
+ integer, dimension(:),pointer:: ghostsize
+ !> bool to reset (or not) particles positions
+ logical, intent(in) :: resetpos
+ real(mk),dimension(dim3),intent(in) :: coordMin,step
+ integer, dimension(dim3),intent(in) :: resolution
+ !> Error status
+ integer :: dir
+
+ do dir=1,dime
+ !call ppm_rmsh_create_part(topoid,meshid,xp,npart,scalar_p,scalar,cutoff,info,resetpos,&
+ ! field_wp=velocity,wp=velop,lda2=dime)
+ call reset_parts(scalar,resolution,coordMin,step)
+ write(*,'(a,i5,a,i8)') '[',rank,'] initialisation with ', npart,' particles'
+ ! Integrate
+ call push_split_particles(dir,dt,topoid,topoid,ghostsize,velocity,coordMin,step)
+ ! Remesh
+ call remesh_split_mp6(scalar,dir,step,coordMin)
+
+ if(dir == c_X) then
+ scalar(-ghostsize(c_X)+1:ghostsize(c_X)+1,:,:) = scalar(-ghostsize(c_X)+1:ghostsize(c_X)+1,:,:) &
+ + scalar(resolution(c_X)-ghostsize(c_X):resolution(c_X)+ghostsize(c_X),:,:)
+ scalar(resolution(c_X)-ghostsize(c_X):resolution(c_X)+ghostsize(c_X),:,:) = scalar(-ghostsize(c_X)&
+ +1:ghostsize(c_X)+1,:,:)
+ else if(dir == c_Y) then
+ scalar(:,-ghostsize(c_Y)+1:ghostsize(c_Y)+1,:) = scalar(:,-ghostsize(c_Y)+1:ghostsize(c_Y)+1,:) &
+ + scalar(:,resolution(c_Y)-ghostsize(c_Y):resolution(c_Y)+ghostsize(c_Y),:)
+ scalar(:,resolution(c_Y)-ghostsize(c_Y):resolution(c_Y)+ghostsize(c_Y),:) = scalar(:,-ghostsize(c_Y)&
+ +1:ghostsize(c_Y)+1,:)
+ else
+ scalar(:,:,-ghostsize(c_Z)+1:ghostsize(c_Z)+1) = scalar(:,:,-ghostsize(c_Z)+1:ghostsize(c_Z)+1) &
+ + scalar(:,:,resolution(c_Z)-ghostsize(c_Z):resolution(c_Z)+ghostsize(c_Z))
+ scalar(:,:,resolution(c_Z)-ghostsize(c_Z):resolution(c_Z)+ghostsize(c_Z)) = scalar(:,:,-ghostsize(c_Z)&
+ +1:ghostsize(c_Z)+1)
+ end if
+ end do
+ ! Ghost values for vorticity
+!!$ call ppm_map_field_ghost_get(topoid,meshid,ghostsize,info)
+!!$ call ppm_map_field_push(topoid,meshid,scalar,info)
+!!$ call ppm_map_field_send(info)
+!!$ call ppm_map_field_pop(topoid,meshid,scalar,ghostsize,info)
+
+ end subroutine ScalarSolver_particles
+
+ subroutine init_parts(scalar,velocity,resolution,coordMin,step)
+ real(mk),dimension(:,:,:), pointer :: scalar
+ real(mk),dimension(:,:,:,:),pointer :: velocity
+ real(mk),dimension(dim3),intent(in)::coordMin,step
+ integer, dimension(dim3),intent(in)::resolution
+
+ integer :: i,j,k,current_part
+ real(mk),dimension(dim3) :: coord
+
+ current_part = 1
+ npart = product(resolution-1)
+ allocate(xp(dime,npart),velop(dime,npart),scalar_p(npart),buffer(dime,npart))
+ do k=1,resolution(c_Z)-1
+ coord(c_Z) = coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)-1
+ coord(c_Y) = coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)-1
+ coord(c_X) = coordMin(c_X) + (i-1)*step(c_X)
+ xp(:,current_part) = coord(:)
+ velop(:,current_part) = velocity(:,i,j,k)
+ scalar_p(current_part) = scalar(i,j,k)
+ current_part = current_part + 1
+
+ end do
+ end do
+ end do
+
+
+ endsubroutine init_parts
+
+ subroutine reset_parts(scalar,resolution,coordMin,step)
+
+ real(mk),dimension(:,:,:), pointer :: scalar
+ real(mk),dimension(dime),intent(in)::coordMin,step
+ integer, dimension(dime),intent(in)::resolution
+
+ integer :: i,j,k,current_part
+ real(mk),dimension(dim3) :: coord
+
+ current_part = 1
+ do k=1,resolution(c_Z)-1
+ coord(c_Z) = coordMin(c_Z) + (k-1)*step(c_Z)
+ do j=1,resolution(c_Y)-1
+ coord(c_Y) = coordMin(c_Y) + (j-1)*step(c_Y)
+ do i=1,resolution(c_X)-1
+ coord(c_X) = coordMin(c_X) + (i-1)*step(c_X)
+ xp(:,current_part) = coord(:)
+ scalar_p(current_part) = scalar(i,j,k)
+ current_part = current_part + 1
+ end do
+ end do
+ end do
+
+ endsubroutine reset_parts
+
+
+ !> Set required parameters for particles creations
+ subroutine initNSSolver_particles()
+
+ ! Cutoff : lower and upper bound for cutoff, i.e. for each value of the ref. field between cutoff(1) and cutoff(2), a particle will be
+ ! created.
+ cutoff(1) = 1.d-8
+ cutoff(2) = 1e9!00000
+ kernel = ppm_param_rmsh_kernel_mp4
+ npart = 0
+ buffer_size = npart
+ end subroutine initNSSolver_particles
+
+
+
+ !> PPM-based creation/update of particles distribution
+ subroutine PPMupdateParticles3D(field_on_grid,resetpos,topoid,meshid,vel)
+ !> The field used to create particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: field_on_grid
+ !> true to reset distribution else false
+ logical, intent(in) :: resetpos
+ !> topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer :: info
+ !> velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: vel
+ info = 0
+
+ ! --------> The following call will allocate memory for xp, omp and velop
+ ! --------> And deallocation will be handled by ppm. (?)
+ ! --------> Other variables carried by particles but not allocated during ppm_rmsh_create call
+ ! --------> is there a better way to do this, with map_push or other ppm routines? No according to Omar.
+ ! Call ppm func to create the particles distribution
+ call ppm_rmsh_create_part(topoid,meshid,xp,npart,omp,dime,field_on_grid,cutoff,info,resetpos,&
+ field_wp=vel,wp=velop,lda2=dime)
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ !if(associated(xp)) print *, "xp shape:", rank, " ", shape(xp), npart
+ ! --------> Ok, from here all vars carried by particles must have the following shape : dime,npart
+ !> --------> mesh to particles for velocity => done in ppm_rmsh_create_part
+ ! call ppm_interp_m2p(topoid, meshid, xp, npart, velop, dime, kernel, ghostsize, vel,info)
+ ! print *, 'End of update particles'
+
+ end subroutine PPMupdateParticles3D
+
+ subroutine PPMupdateParticles2DScalar(field_on_grid,resetpos,topoid,meshid,vel)
+ !> The field used to create particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:), pointer :: field_on_grid
+ !> true to reset distribution else false
+ logical, intent(in) :: resetpos
+ !> topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer :: info,i
+ !> velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+ info = 0
+
+ ! --------> The following call will allocate memory for xp, omp and velop
+ ! --------> And deallocation will be handled by ppm. (?)
+ ! --------> Other variables carried by particles but not allocated during ppm_rmsh_create call
+ ! --------> is there a better way to do this, with map_push or other ppm routines? No according to Omar.
+ ! Call ppm func to create the particles distribution
+ call ppm_rmsh_create_part(topoid,meshid,xp,npart,scalar_p,field_on_grid,cutoff,info,.true.,&
+ field_wp=vel,wp=velop,lda2=dime)
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ open(45,file="omp") ! Output only for one process
+ do i = 1,npart
+ write(45,'(3(11e14.5))') xp(c_X,i),scalar_p(i)
+ end do
+ close(45)
+
+
+ !if(associated(xp)) print *, "xp shape:", rank, " ", shape(xp), npart
+ ! --------> Ok, from here all vars carried by particles must have the following shape : dime,npart
+ !> --------> mesh to particles for velocity => done in ppm_rmsh_create_part
+ ! call ppm_interp_m2p(topoid, meshid, xp, npart, velop, dime, kernel, ghostsize, vel,info)
+ ! print *, 'End of update particles'
+
+ end subroutine PPMupdateParticles2DScalar
+
+ subroutine PPMupdateParticles2D(field_on_grid,resetpos,topoid,meshid,vel)
+ !> The field used to create particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: field_on_grid
+ !> true to reset distribution else false
+ logical, intent(in) :: resetpos
+ !> topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer :: info
+ !> velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+ info = 0
+
+ ! --------> The following call will allocate memory for xp, omp and velop
+ ! --------> And deallocation will be handled by ppm. (?)
+ ! --------> Other variables carried by particles but not allocated during ppm_rmsh_create call
+ ! --------> is there a better way to do this, with map_push or other ppm routines? No according to Omar.
+ ! Call ppm func to create the particles distribution
+ call ppm_rmsh_create_part(topoid,meshid,xp,npart,omp,dime,field_on_grid,cutoff,info,resetpos,&
+ field_wp=vel,wp=velop,lda2=dime)
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ !if(associated(xp)) print *, "xp shape:", rank, " ", shape(xp), npart
+ ! --------> Ok, from here all vars carried by particles must have the following shape : dime,npart
+ !> --------> mesh to particles for velocity => done in ppm_rmsh_create_part
+ ! call ppm_interp_m2p(topoid, meshid, xp, npart, velop, dime, kernel, ghostsize, vel,info)
+ ! print *, 'End of update particles'
+
+ end subroutine PPMupdateParticles2D
+
+ !> time integration
+ !> Advection of particles, more or less a copy of Adrien's code.
+ subroutine push_particles(dt,topoid,meshid,ghostsize,vel,rhs)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer:: ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: vel
+ ! Secondary field to be mapped to particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: rhs
+
+ ! Compute new particles positions ...
+ ! Integrate ... ===> update omp
+ ! Todo: switch process between the different methods, leaded by a user-defined var? Later ...
+ ! call runge_kutta_2(dt,topoid,meshid,ghostsize,vel,rhs)
+ call RK4_3D(dt,topoid,meshid,ghostsize,vel,rhs)
+ end subroutine push_particles
+
+ subroutine PPMremesh3D(topoid,meshid,ghostsize,field)
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer :: ghostsize
+ ! vorticity on grid, (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: field
+
+ integer info
+ info = -1
+ !call ppm_dbg_print_d(topoid,ghostlayer,1,1,info,xp,npart)
+ call ppm_interp_p2m(topoid,meshid,xp,npart,omp,dime,kernel,ghostsize,field,info)
+ if(info.ne.0) then
+ stop 'Particles: ppm remesh error '
+ end if
+ end subroutine PPMremesh3D
+
+ subroutine PPMremesh2D(topoid,meshid,ghostsize,field)
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer :: ghostsize
+ ! vorticity on grid, (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: field
+
+ integer info
+ info = -1
+ !call ppm_dbg_print_d(topoid,ghostlayer,1,1,info,xp,npart)
+ call ppm_interp_p2m(topoid,meshid,xp,npart,omp,dime,kernel,ghostsize,field,info)
+ if(info.ne.0) then
+ stop 'Particles: ppm remesh error '
+ end if
+ end subroutine PPMremesh2D
+ subroutine PPMremesh2DScalar(topoid,meshid,ghostsize,field)
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer :: ghostsize
+ ! vorticity on grid, (must be in PPM-style storage)
+ real(mk), dimension(:,:,:), pointer :: field
+
+ integer info
+ info = -1
+ !call ppm_dbg_print_d(topoid,ghostlayer,1,1,info,xp,npart)
+ call ppm_interp_p2m(topoid,meshid,xp,npart,scalar_p,kernel,ghostsize,field,info)
+ if(info.ne.0) then
+ stop 'Particles: ppm remesh error '
+ end if
+ end subroutine PPMremesh2DScalar
+
+ !> Runge Kutta 2 for positions and 1 for vorticity
+ subroutine RK2_3D(dt,topoid,meshid,ghostsize,vel,rhs)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer:: ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: vel
+ ! Secondary field to be mapped to particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: rhs
+
+ !> local loop indices
+ integer :: i,newNpart,k
+ integer :: info
+
+ ! buffer must be of the same size as xp so if the number of particles has increased in comparison with previous step,
+ ! we reallocate secondary fields.
+ ! Note Franck : Either we allocate buffer at each time step or we reallocate only when buffer_size increase.
+ ! Since memory is our main problem, we allocate/deallocate at each time step, for the moment.
+ ! if(buffer_size.lt.npart) then
+ ! deallocate(buffer)
+ allocate(buffer(dime,npart))
+ buffer_size = npart
+
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+0.5*dt*velop(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ ! call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+ ! if(size(rhsp,2).lt.npart) then
+ ! deallocate(rhsp)
+ allocate(rhsp(dime,npart))
+ ! end if
+!! print *, 'max min omp start', maxval(omp),minval(omp),maxval(rhsp),minval(rhsp)
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ !> for rhs of vorticity eq.
+ call ppm_interp_m2p(topoid,meshid,xp,npart,rhsp,dime,kernel,ghostsize,rhs,info)
+ ! Update positions according to the new velocity and vorticity with new rhs
+
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+dt*velop(k,i)
+ omp(k,i)=omp(k,i)+dt*rhsp(k,i)
+ end do
+ end do
+!! print *, 'max min omp stop', maxval(omp),minval(omp), maxval(rhsp),minval(rhsp)
+
+ ! Free memory as soon as possible ...
+ deallocate(buffer,rhsp)
+ ! Vorticity mapping ...
+ newNpart = 0
+
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+
+ end subroutine RK2_3D
+
+ !> Runge Kutta 4
+ subroutine RK4_3D(dt,topoid,meshid,ghostsize,vel,rhs)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer::ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: vel
+ ! Secondary field to be mapped to particles (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:,:), pointer :: rhs
+
+ !> local loop indices
+ integer :: i, newNpart,k
+ real(mk) :: alpha
+ !> error status
+ integer :: info
+ ! buffer is used to save intermediate values for xp and omp, thus buffersize=2*npart
+
+ allocate(buffer(dime,npart),buffer2(dime,npart),buffer3(dime,npart),rhsp(dime,npart))
+ buffer_size=npart
+
+ !> Compute current rhs on particles
+ call ppm_interp_m2p(topoid,meshid,xp,npart,rhsp,dime,kernel,ghostsize,rhs,info)
+ ! First RK stage
+ ! Velocity is up to date, following the call to update_particles
+ alpha=0.5*dt
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=velop(k,i)
+ buffer3(k,1)=rhsp(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ ! call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_push(buffer3,dime,npart,info)
+ call ppm_map_part_push(rhsp,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(rhsp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer3,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ call ppm_interp_m2p(topoid,meshid,xp,npart,rhsp,dime,kernel,ghostsize,rhs,info)
+
+ !! Second RK4 stage, with the updated velocity
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ buffer3(k,i)=buffer3(k,i)+2.*rhsp(k,i)
+ end do
+ end do
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_push(buffer3,dime,npart,info)
+ call ppm_map_part_push(rhsp,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(rhsp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer3,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ call ppm_interp_m2p(topoid,meshid,xp,npart,rhsp,dime,kernel,ghostsize,rhs,info)
+
+ !! Third RK4 stage
+ alpha=dt
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ buffer3(k,i)=buffer3(k,i)+2.*rhsp(k,i)
+ end do
+ end do
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_push(buffer3,dime,npart,info)
+ call ppm_map_part_push(rhsp,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(rhsp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer3,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ call ppm_interp_m2p(topoid,meshid,xp,npart,rhsp,dime,kernel,ghostsize,rhs,info)
+
+ !! Last RK4 stage
+ alpha=dt/6.
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*buffer2(k,i)+alpha*velop(k,i)
+ omp(k,i)=omp(k,i)+alpha*buffer3(k,i)+alpha*rhsp(k,i)
+ end do
+ end do
+
+ ! Free memory as soon as possible ...
+ deallocate(buffer,buffer2,buffer3,rhsp)
+ ! Vorticity mapping ...
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+
+ end subroutine RK4_3D
+
+ !> Runge Kutta 4, for 2D domain (i.e rhs == 0).
+ subroutine RK4_2D(dt,topoid,meshid,ghostsize,vel)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer::ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+
+ !> local loop indices
+ integer :: i, newNpart,k
+ real(mk) :: alpha
+ !> error status
+ integer :: info
+ ! buffer is used to save intermediate values for xp and omp, thus buffersize=2*npart
+
+ allocate(buffer(dime,npart),buffer2(dime,npart))
+ buffer_size=npart
+
+ ! First RK stage
+ ! Velocity is up to date, following the call to update_particles
+ alpha=0.5*dt
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=velop(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ print *, "NEW", npart,newNpart
+ npart = newNpart
+
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Second RK4 stage, with the updated velocity
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ end do
+ end do
+ call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ print *, "NEW2", npart,newNpart
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Third RK4 stage
+ alpha=dt
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ end do
+ end do
+ newNpart = 0
+ call ppm_impose_part_bc(topoid,xp,npart,info)
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ print *, "NEW3", npart,newNpart
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Last RK4 stage
+ alpha=dt/6.
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*buffer2(k,i)+alpha*velop(k,i)
+ end do
+ end do
+
+ ! Free memory as soon as possible ...
+ deallocate(buffer,buffer2)
+ ! Vorticity mapping ...
+ call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ print *, "NEW4", npart,newNpart
+ npart = newNpart
+
+ end subroutine RK4_2D
+
+ !> Runge Kutta 4, for 2D domain (i.e rhs == 0).
+ subroutine RK4_2DScalar(dt,topoid,meshid,ghostsize,vel)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer::ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+
+ !> local loop indices
+ integer :: i, newNpart,k
+ real(mk) :: alpha
+ !> error status
+ integer :: info
+ ! buffer is used to save intermediate values for xp and omp, thus buffersize=2*npart
+
+ allocate(buffer(dime,npart),buffer2(dime,npart))
+ buffer_size=npart
+
+ ! First RK stage
+ ! Velocity is up to date, following the call to update_particles
+ alpha=0.5*dt
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=velop(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ !call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ !! Second RK4 stage, with the updated velocity
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ end do
+ end do
+! call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Third RK4 stage
+ alpha=dt
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ buffer2(k,i)=buffer2(k,i)+2.*velop(k,i)
+ end do
+ end do
+ newNpart = 0
+ !call ppm_impose_part_bc(topoid,xp,npart,info)
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_push(buffer2,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer2,dime,npart,newNpart,info)
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Last RK4 stage
+ alpha=dt/6.
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+alpha*buffer2(k,i)+alpha*velop(k,i)
+ end do
+ end do
+
+ ! Scalar mapping ...
+ !call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+ ! Free memory as soon as possible ...
+ deallocate(buffer,buffer2)
+
+ end subroutine RK4_2DSCALAR
+
+ !> Runge Kutta 4, for 2D domain (i.e rhs == 0).
+ subroutine RK2_2D(dt,topoid,meshid,ghostsize,vel)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer::ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+
+ !> local loop indices
+ integer :: i, newNpart,k
+ real(mk) :: alpha
+ !> error status
+ integer :: info
+ ! buffer is used to save intermediate values for xp and omp, thus buffersize=2*npart
+
+ allocate(buffer(dime,npart))
+ buffer_size=npart
+
+ ! First RK stage
+ ! Velocity is up to date, following the call to update_particles
+ alpha=0.5*dt
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ ! call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+
+ !! Second RK2 stage, with the updated velocity
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+dt*velop(k,i)
+ end do
+ end do
+ ! Vorticity mapping ...
+ ! call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(omp,dime,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(omp,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+ ! Free memory as soon as possible ...
+ deallocate(buffer)
+
+ end subroutine RK2_2D
+
+ !> Runge Kutta 2, for 2D domain (i.e rhs == 0).
+ subroutine RK2_2DScalar(dt,topoid,meshid,ghostsize,vel)
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer::ghostsize
+ ! velocity on grid (must be in PPM-style storage)
+ real(mk), dimension(:,:,:,:), pointer :: vel
+
+ !> local loop indices
+ integer :: i, newNpart,k
+ real(mk) :: alpha
+ !> error status
+ integer :: info,np0
+ ! buffer is used to save intermediate values for xp and omp, thus buffersize=2*npart
+
+ allocate(buffer(dime,npart))
+ buffer_size=npart
+
+ np0 = npart
+
+ ! First RK stage
+ ! Velocity is up to date, following the call to update_particles
+ alpha=0.5*dt
+ do i=1,npart
+ do k=1,dime
+ buffer(k,i)=xp(k,i)
+ xp(k,i)=buffer(k,i)+alpha*velop(k,i)
+ end do
+ end do
+ ! Particles positions have changed ... we must map between domains
+ !call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+ !! Mesh to particles for the new particles positions ...
+ !> for velocity and rhs
+ call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ !! Second RK2 stage, with the updated velocity
+ do i=1,npart
+ do k=1,dime
+ xp(k,i)=buffer(k,i)+dt*velop(k,i)
+ end do
+ end do
+ ! call ppm_impose_part_bc(topoid,xp,npart,info)
+ newNpart = 0
+ ! call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+ end subroutine RK2_2DSCALAR
+
+ !> Runge Kutta 2 for positions and 1 for vorticity
+ subroutine push_split_particles(dir,dt,topoid,meshid,ghostsize,vel,coordMin,step)
+ !> splitting direction
+ integer, intent(in) :: dir
+ !> time step
+ real(mk), intent(in) ::dt
+ ! topo and mesh ids
+ integer, intent(in) :: topoid
+ integer, intent(in) :: meshid
+ integer, dimension(:),pointer:: ghostsize
+ ! velocity on grid
+ real(mk), dimension(:,:,:,:), pointer :: vel
+ real(mk),dimension(dim3),intent(in) :: coordMin,step
+ !> local loop indices
+ integer :: i,newNpart
+ integer :: info
+
+ do i=1,npart
+ buffer(dir,i)=xp(dir,i)
+ xp(dir,i)=buffer(dir,i)+0.5*dt*velop(dir,i)
+ end do
+ ! Particles positions have changed ... we must map between domains
+ ! call ppm_impose_part_bc(topoid,xp,npart,info) ! Useless according to doc, required according to Omar ...
+ newNpart = 0
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ !call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(velop,dime,npart,info) ! velocity
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_push(buffer,dime,npart,info)
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(buffer,dime,npart,newNpart,info)
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(velop,dime,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ ! Update sizes ...
+ npart = newNpart
+ ! if(size(rhsp,2).lt.npart) then
+
+ !> for velocity
+ !call ppm_interp_m2p(topoid,meshid,xp,npart,velop,dime,kernel,ghostsize,vel,info)
+ call mesh2particles(vel,coordMin,step,dir)
+
+ do i=1,npart
+ xp(dir,i)=buffer(dir,i)+dt*velop(dir,i)
+ end do
+
+ ! Vorticity mapping ...
+ newNpart = 0
+
+ call ppm_map_part_partial(topoid,xp,npart,info) ! positions
+ call ppm_map_part_global(topoid,xp,npart,info) ! positions
+ call ppm_map_part_push(scalar_p,npart,info) ! vorticity
+ call ppm_map_part_send(npart,newNpart,info) ! send
+ call ppm_map_part_pop(scalar_p,npart,newNpart,info)
+ call ppm_map_part_pop(xp,dime,npart,newNpart,info)
+ npart = newNpart
+ end subroutine push_split_particles
+
+ subroutine mesh2particles(velocity,coordMin,step,dir)
+
+ real(mk),dimension(:,:,:,:),pointer :: velocity
+ integer, intent(in) :: dir
+ real(mk),dimension(dim3),intent(in) :: step
+ real(mk),dimension(dim3),intent(in) :: coordMin
+
+ real(mk) :: coord,dist
+ real(mk),dimension(2) :: weights
+ integer :: i,j
+ integer, dimension(2,dime) :: indGrid
+
+ do i = 1,npart
+ do j = 1,2
+ indGrid(j,:) = ((xp(:,i) - coordMin(:))/step(:) + epsilon(pi))+1
+ enddo
+ indGrid(2,dir) = indGrid(1,dir) + 1
+
+ coord = coordMin(dir) + (indGrid(1,dir)-1)*step(dir)
+ dist = (xp(dir,i) - coord)/step(dir)
+ weights(1) = 1.-dist
+ weights(2) = dist
+
+ velop(dir,i) = weights(1)*velocity(dir,indGrid(1,1),indGrid(1,2),indGrid(1,3))&
+ + weights(2)*velocity(dir,indGrid(2,1),indGrid(2,2),indGrid(2,3))
+ end do
+
+ end subroutine mesh2particles
+
+ subroutine remesh_split_mp6(scalar,dir,step,coordMin)
+ real(mk),dimension(:,:,:), pointer :: scalar
+ integer, intent(in) :: dir
+ real(mk),dimension(dim3),intent(in) :: step
+ real(mk),dimension(dim3),intent(in) :: coordMin
+
+ real(mk) :: coord,dist
+ real(mk),dimension(6) :: val,weights
+ integer :: i,j
+
+ integer, dimension(6,dime) :: indGrid
+
+ scalar = 0.0
+
+ do i = 1,npart
+ do j = 1,6
+ indGrid(j,:) = ((xp(:,i) - coordMin(:))/step(:) + epsilon(pi))+1
+ enddo
+ indGrid(1,dir) = indGrid(3,dir) - 2
+ indGrid(2,dir) = indGrid(3,dir) - 1
+ indGrid(4,dir) = indGrid(3,dir) + 1
+ indGrid(5,dir) = indGrid(3,dir) + 2
+ indGrid(6,dir) = indGrid(3,dir) + 3
+
+ coord = coordMin(dir) + (indGrid(3,dir)-1)*step(dir)
+ dist = (xp(dir,i) - coord)/step(dir)
+ weights(1) = -(dist)*(5.*(dist + 2.)-8.)*(dist - 1.)**3/24.
+ weights(2) = (dist)*(dist - 1.)*(25.*(dist + 1.)**3-114.*(dist + 1.)**2+153.*(dist + 1.)-48.)/24.
+ weights(3) = -(dist-1.)*(25.*dist**4-38.*dist**3-3.*dist**2+12.*dist+12)/12.
+ weights(4) = (dist)*(25.*(1. - dist)**4-38.*(1. - dist)**3-3.*(1. - dist)**2+12.*(1. - dist)+12)/12.
+ weights(5) = (1. - dist)*(-dist)*(25.*(2. - dist)**3-114.*(2. - dist)**2+153.*(2. - dist)-48.)/24.
+ weights(6) = -(1. - dist)*(5.*(3. - dist)-8.)*(-dist)**3/24.
+
+ val(:) = scalar_p(i)*weights(:)
+ do j = 1, 6
+ scalar(indGrid(j,c_X),indGrid(j,c_Y),indGrid(j,c_Z)) = &
+ scalar(indGrid(j,c_X),indGrid(j,c_Y),indGrid(j,c_Z)) + val(j)
+ end do
+
+ end do
+
+ end subroutine remesh_split_mp6
+
+
+ !> Return the memory used to save var. attached to particles
+ function getMemoryUsedForParticles()
+ real(mk) :: getMemoryUsedForParticles
+
+ getMemoryUsedForParticles = sizeof(xp)+sizeof(velop)+sizeof(rhsp)+sizeof(buffer)+&
+ sizeof(buffer2)+sizeof(buffer3)
+ getMemoryUsedForParticles = getMemoryUsedForParticles*1e-6
+ if(verbose) then
+ write(*,'(a,i3,a,f10.4,a)') &
+ '[',rank,'] memory used for particles:', getMemoryUsedForParticles, ' MB.'
+ end if
+
+ end function getMemoryUsedForParticles
+
+ !> Create particles on the grid points where refField>cutoff.
+ subroutine countAndCreateParticles(refField,velocity,resolution,step,coordMin)
+
+ !> Field (on grid) used to set particles
+ real(mk), dimension(:,:,:,:), pointer :: refField
+ !> velocity on the grid
+ real(mk), dimension(:,:,:,:), pointer :: velocity
+ !> Local resolution
+ integer, dimension(dim3),intent(in) :: resolution
+ !> Space step
+ real(mk), dimension(dim3),intent(in) :: step
+ !> Coordinates of the lowest point of the current domain
+ real(mk), dimension(dim3),intent(in) :: coordMin
+
+ ! particles counter
+ integer :: count
+ ! norm of refField at each point of the grid
+ real(mk) :: strength
+ ! coordinates
+ real(mk), dimension(dim3) :: coord
+ integer, dimension(dim3) :: nbCells
+
+ integer :: i,j,k
+
+ nbCells = max(resolution-1,1)
+
+ print *, "uuuu",maxval(refField)
+
+ ! Count the number of particles within cutoff bounds.
+ ! Loop over grid points. We use 'max' to allow the '1 point in one direction' case
+ ! (i.e. to deal with 2D case in a 3D context)
+ ! Remark : there is no resize function in fortran so we must count first, allocate and then fill fields.
+ count = 0
+
+ print *, "str", cutoff
+ do k=1,nbCells(c_Z)
+ do j=1,nbCells(c_Y)
+ do i=1,nbCells(c_X)
+ strength = sqrt(sum(refField(:,i,j,k)**2))
+ if((strength.gt.cutoff(1)).and.(strength.lt.cutoff(2))) then
+ count = count + 1
+ end if
+ end do
+ end do
+ end do
+
+ ! Allocations
+ allocate(xp(dime,count),omp(dime,count),velop(dime,count))
+
+ print *, 'nb parts ...', count, shape(xp)
+
+ ! and set values
+ coord = coordMin
+ count = 0
+ do k=1,nbCells(c_Z)
+ do j=1,nbCells(c_Y)
+ do i=1,nbCells(c_X)
+ strength = sqrt(sum(refField(:,i,j,k)**2))
+ if((strength.gt.cutoff(1)).and.(strength.lt.cutoff(2))) then
+ count = count + 1
+ omp(:,count) = refField(:,i,j,k)
+ velop(:,count) = velocity(:,i,j,k)
+ xp(:,count) = coord(1:dime)
+ end if
+ coord(c_X) = coord(c_X) + step(c_X)
+ end do
+ coord(c_Y) = coord(c_Y) + step(c_Y)
+ end do
+ coord(c_Z) = coord(c_Z) + step(c_X)
+ end do
+
+ npart = count
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ end subroutine countAndCreateParticles
+
+ !> Update particles on the grid points where refField>cutoff.
+ !! Note : There are deallocation/reallocation if the number of particles as increased.
+ subroutine countAndUpdateParticles(refField,velocity,resolution,step,coordMin)
+
+ !> Field (on grid) used to set particles
+ real(mk), dimension(:,:,:,:), pointer :: refField
+ !> velocity on the grid
+ real(mk), dimension(:,:,:,:), pointer :: velocity
+ !> Local resolution
+ integer, dimension(dim3),intent(in) :: resolution
+ !> Space step
+ real(mk), dimension(dim3),intent(in) :: step
+ !> Coordinates of the lowest point of the current domain
+ real(mk), dimension(dim3),intent(in) :: coordMin
+
+ ! particles counter
+ integer :: count
+ ! norm of refField at each point of the grid
+ real(mk) :: strength
+ ! coordinates
+ real(mk), dimension(dim3) :: coord
+ integer, dimension(dim3) :: nbCells
+ integer :: i,j,k
+
+ nbCells = max(resolution-1,1)
+
+ ! Count the number of particles within cutoff bounds.
+ ! Loop over grid points. We use 'max' to allow the '1 point in one direction' case
+ ! (i.e. to deal with 2D case in a 3D context)
+ ! Remark : there is no resize function in fortran so we must count first, allocate and then fill fields.
+ count = 0
+ do k=1,max(resolution(c_Z)-1,1)
+ do j=1,max(resolution(c_Y)-1,1)
+ do i=1,max(resolution(c_X)-1,1)
+ strength = sqrt(sum(refField(:,i,j,k)**2))
+ if((strength.gt.cutoff(1)).and.(strength.lt.cutoff(2))) then
+ count = count + 1
+ end if
+ end do
+ end do
+ end do
+
+ ! Check if reallocation is required
+ if(count > npart) then
+ ! Free old memory
+ if(associated(xp)) deallocate(xp)
+ if(associated(omp)) deallocate(omp)
+ if(associated(velop)) deallocate(velop)
+
+ ! Allocations
+ allocate(xp(dime,count),omp(dime,count),velop(dime,count))
+ end if
+
+ ! and set values
+ coord = coordMin
+ count = 0
+ do k=1,max(resolution(c_Z)-1,1)
+ do j=1,max(resolution(c_Y)-1,1)
+ do i=1,max(resolution(c_X)-1,1)
+ strength = sqrt(sum(refField(:,i,j,k)**2))
+ if((strength.gt.cutoff(1)).and.(strength.lt.cutoff(2))) then
+ count = count + 1
+ omp(:,count) = refField(:,i,j,k)
+ velop(:,count) = velocity(:,i,j,k)
+ xp(:,count) = coord
+ end if
+ coord(c_X) = coord(c_X) + step(c_X)
+ end do
+ coord(c_Y) = coord(c_Y) + step(c_Y)
+ end do
+ coord(c_Z) = coord(c_Z) + step(c_X)
+ end do
+
+ npart = count
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+ end subroutine countAndUpdateParticles
+
+ !> Create particles on the grid points where refField>cutoff.
+ subroutine createParticlesEverywhere(refField,velocity,resolution,step,coordMin)
+
+ !> Field (on grid) used to set particles
+ real(mk), dimension(:,:,:,:), pointer :: refField
+ !> velocity on the grid
+ real(mk), dimension(:,:,:,:), pointer :: velocity
+ !> Local resolution
+ integer, dimension(dim3),intent(in) :: resolution
+ !> Space step
+ real(mk), dimension(dim3),intent(in) :: step
+ !> Coordinates of the lowest point of the current domain
+ real(mk), dimension(dim3),intent(in) :: coordMin
+
+ ! coordinates
+ real(mk), dimension(dim3) :: coord
+ integer, dimension(dim3) :: nbCells
+ integer :: i,j,k,count
+
+ nbCells = max(resolution-1,1)
+ coord = coordMin
+ count = 0
+ npart = product(nbCells)
+ ! Allocations
+ allocate(xp(dime,npart),omp(dime,npart),velop(dime,npart))
+ do k=1,nbCells(c_Z)
+ do j=1,nbCells(c_Y)
+ do i=1,nbCells(c_X)
+ count = count + 1
+ omp(:,count) = refField(:,i,j,k)
+ velop(:,count) = velocity(:,i,j,k)
+ xp(:,count) = coord
+ coord(c_X) = coord(c_X) + step(c_X)
+ end do
+ coord(c_X) = coordMin(c_X)
+ coord(c_Y) = coord(c_Y) + step(c_Y)
+ end do
+ coord(c_Y) = coordMin(c_Y)
+ coord(c_Z) = coord(c_Z) + step(c_X)
+ end do
+
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ end subroutine createParticlesEverywhere
+
+ !> Create particles on the grid points where refField>cutoff.
+ subroutine createParticlesEverywhereScalar(refField,velocity,resolution,step,coordMin)
+
+ !> Field (on grid) used to set particles
+ real(mk), dimension(:,:,:), pointer :: refField
+ !> velocity on the grid
+ real(mk), dimension(:,:,:,:), pointer :: velocity
+ !> Local resolution
+ integer, dimension(dim3),intent(in) :: resolution
+ !> Space step
+ real(mk), dimension(dim3),intent(in) :: step
+ !> Coordinates of the lowest point of the current domain
+ real(mk), dimension(dim3),intent(in) :: coordMin
+
+ ! coordinates
+ real(mk), dimension(dim3) :: coord
+ integer, dimension(dim3) :: nbCells
+ integer :: i,j,k,count
+
+ nbCells = max(resolution-1,1)
+ coord = coordMin
+ count = 0
+ npart = product(nbCells)
+ ! Allocations
+ allocate(xp(dime,npart),scalar_p(npart),velop(dime,npart))
+ do k=1,nbCells(c_Z)
+ do j=1,nbCells(c_Y)
+ do i=1,nbCells(c_X)
+ count = count + 1
+ scalar_p(count) = refField(i,j,k)
+ velop(:,count) = velocity(:,i,j,k)
+ xp(:,count) = coord
+ coord(c_X) = coord(c_X) + step(c_X)
+ end do
+ coord(c_X) = coordMin(c_X)
+ coord(c_Y) = coord(c_Y) + step(c_Y)
+ end do
+ coord(c_Y) = coordMin(c_Y)
+ coord(c_Z) = coord(c_Z) + step(c_X)
+ end do
+
+ write(*,'(a,i5,a,i8,a)') '[',rank,'] initialisation with ', npart,' particles'
+
+ open(45,file="scalp") ! Output only for one process
+ do i = 1,npart
+ write(45,'(6e14.5)') xp(c_X,i),scalar_p(i)
+ end do
+ close(45)
+ end subroutine createParticlesEverywhereScalar
+
+
+ !> Free all arrays carried by particles
+ !! useful only for tests.
+ ! --------> is it required to call some specific routines to clean anything related to particles, at the end of the simulation?
+ ! or ppm_finalize do it all?
+ ! According to Omar: do not use ppm "internal" routines but clean it yourself.
+ subroutine freeParticles()
+ if(associated(xp)) deallocate(xp)
+ if(associated(omp)) deallocate(omp)
+ if(associated(velop)) deallocate(velop)
+ if(associated(rhsp)) deallocate(rhsp)
+ if(associated(buffer)) deallocate(buffer)
+ if(associated(buffer2)) deallocate(buffer2)
+ if(associated(scalar_p)) deallocate(scalar_p)
+ npart = 0
+ buffer_size = 0
+ end subroutine freeParticles
+
+ subroutine remesh2D(field,coordMin,step,resolution)
+
+ real(mk),dimension(:,:,:),pointer :: field
+ real(mk),dimension(dim3),intent(in) :: coordMin
+ real(mk),dimension(dim3),intent(in) :: step
+ integer, dimension(dim3),intent(in) :: resolution
+
+ real(mk),dimension(dime) :: invStep
+ !! List of grid point indices for each particle : [Left-1 Left Right Right+1]
+ !! Left/Right == left/right points of the grid around the particle
+ integer, dimension(4,dime) :: indGrid
+ !! current point coordinates and distance to the left boundary of the local domain
+ real(mk),dimension(dime) :: coord,dist
+ !! weights
+ real(mk),dimension(4,dime) :: weights
+ integer:: i,j
+ invStep = 1./step(1:dime)
+ do i = 1,npart
+ indGrid(2,:) = ((xp(:,i) - coordMin(:))*invStep(:) + epsilon(pi))+1
+ indGrid(1,:) = indGrid(2,:) - 1
+ indGrid(3,:) = indGrid(2,:) + 1
+ indGrid(4,:) = indGrid(2,:) + 2
+ !enforce periodicity
+ do j =1,4
+ indGrid(j,:) = mod(indGrid(j,:)+resolution(1:dime),resolution(1:dime))+1
+ end do
+
+ coord = coordMin(1:dime) + (indGrid(2,:)-1)*step(1:dime)
+ dist = (xp(:,i) - coord)*invStep
+
+ weights(1,:) = 0.5*dist*((1.-dist)**2)
+ weights(2,:) = 1.-2.5*dist**2+1.5*dist**3
+ weights(3,:) = 1.-2.5*(1.-dist)**2+1.5*(1.-dist)**3
+ weights(4,:) = 0.5*dist**2*(dist-1.)
+
+ do j =1,4
+ field(indGrid(j,c_X),indGrid(:,c_Y),1) = field(indGrid(j,c_X),indGrid(:,c_Y),1)&
+ + weights(j,c_X)*weights(:,c_Y)*scalar_p(i)
+ end do
+
+ end do
+
+ end subroutine remesh2D
+
+
+
+end module Particles
diff --git a/HySoP/src/ppmInterface/Solver.f90 b/HySoP/src/ppmInterface/Solver.f90
new file mode 100755
index 0000000000000000000000000000000000000000..532f0e514190160f32c65233e01a53addc3d772e
--- /dev/null
+++ b/HySoP/src/ppmInterface/Solver.f90
@@ -0,0 +1,164 @@
+!> Poisson Solver on the grid
+!
+! Notes Franck concerning multigrid solver :
+! - the old (before jan 2012) version of this solver was bugged in ppm. I let the Parmes routines calling this solver
+! in the present file for future debugs, but they are not (really not ...) usable.
+
+module Solver
+
+ use client_data, only: mk, dime,rank
+!!!!!!! Comment to remove ppm use ppm_module_numerics_data, only: ppm_param_eq_poisson, ppm_param_smooth_rbsor
+!!!!!!! Comment to remove ppm use ppm_module_poisson, only: ppm_poisson_init, ppm_poisson_plan, ppm_poisson_grn_pois_per, ppm_poisson_solve, &
+!!!!!!! Comment to remove ppm ppm_poisson_drv_curl_fd2, ppm_poisson_drv_curl_fd4, ppm_poisson_drv_none
+!!!!!!! Comment to remove ppm use client_topology
+!!!!!!! Comment to remove ppm use ppm_module_typedef, only : ppm_param_mesh_coarsen
+!!!!!!! Comment to remove ppm use ppm_module_mesh_derive, only: ppm_mesh_derive
+! use ppmljk_poisson
+
+ !! All multigrid stuff ...
+ !!use ppm_module_mg_init
+ !!use ppm_module_mg_solv
+
+ implicit none
+
+ private
+
+ public :: init_poisson_solver, solve_poisson!!!, ppm_poisson_drv_curl_fd2, ppm_poisson_drv_curl_fd4, ppm_poisson_drv_none
+
+ type(ppm_poisson_plan),pointer :: fftwplanForppm => NULL()
+
+ ! Interface to poisson solver initialisation. Only fft at the time
+ interface init_poisson_solver
+ module procedure init_fftw
+ end interface
+
+ interface solve_poisson
+ module procedure solve_poisson_fftw
+ end interface
+
+contains
+
+ !> Do not work, bug in ppm numerics ...
+!!$ subroutine init_multigrid(topoid, meshid, ghostsize, bc)
+!!$
+!!$ integer, intent(in) :: topoid
+!!$ integer, intent(in) :: meshid
+!!$ integer, dimension(:), pointer :: ghostsize
+!!$ integer, dimension(:), pointer :: bc
+!!$
+!!$ integer, dimension(dime,2*dime):: ibcdef
+!!$ real(mk), dimension(dime,1,1,1,1):: ibcvalue
+!!$
+!!$ logical :: with_w_cycles, dump_info
+!!$ real(mk) :: omega
+!!$ integer :: limlev ! Number of mg levels
+!!$ integer :: info
+!!$
+!!$ info = -1
+!!$ limlev = 2 ! Warning, limlev must cope with grid resolution ...
+!!$ omega = 1.15_mk ! Relaxation param
+!!$ with_w_cycles = .FALSE.
+!!$ dump_info = .TRUE.
+!!$ ibcvalue(:,:,:,:,:)=0.0_mk
+!!$ ibcdef(1,:)=bc(:)
+!!$ ibcdef(2,:)=bc(:)
+!!$ ibcdef(3,:)=bc(:)
+!!$ ! Initialize the solver
+!!$ !! ppm_param_eq_poisson : equation type. Poisson is the only possible type ...
+!!$ !! ppm_param_smooth_rbsor : Gauss Seidel, only possible type
+!!$ ! Anyway, at the time the two parameters above are not used in ppm routine.
+!!$ !! maxlev : number of levels in multigrid
+!!$ !!
+!!$
+!!$ call ppm_mg_init(topoid, ppm_param_eq_poisson,ghostsize, ppm_param_smooth_rbsor,dime,ibcdef,&
+!!$ ibcvalue,meshid,limlev,with_w_cycles,dump_info,omega,info)
+!!$
+!!$ if(info.ne.0) stop 'Init_multigrid failed ...'
+!!$
+!!$ end subroutine init_multigrid
+!!$
+!!$ !> Do not work
+!!$ subroutine solve_poisson_multigrid(topoid, field, rhs)
+!!$ integer, intent(in) :: topoid
+!!$ real(mk), dimension(:,:,:,:,:), pointer :: field
+!!$ real(mk), dimension(:,:,:,:,:), pointer :: rhs
+!!$
+!!$ integer :: itera, iterf, iter1, iter2, info
+!!$ real(mk) :: Eu
+!!$
+!!$ itera = 3
+!!$ iterf = 3
+!!$ iter1 = 10
+!!$ iter2 = 4
+!!$ print *, 'solve ...', topoid
+!!$
+!!$ ! Bug inside ...
+!!$ call ppm_mg_solv(topoid, field, rhs, dime, itera, iterf, iter1, iter2, Eu, info)
+!!$
+!!$ end subroutine solve_poisson_multigrid
+
+ !> Init fftw through ppm routines
+ subroutine init_fftw(fieldin,fieldout,topoid,meshid,deriveValue)
+
+ real(mk), dimension(:,:,:,:,:), pointer :: fieldin, fieldout
+ integer, intent(in) :: topoid, meshid
+ integer, intent(in), optional :: deriveValue
+
+ ! Parameters for ppm poisson routine
+ integer :: info
+
+ ! Flag to select built-in Green functions (...)
+ integer :: green
+ integer :: der
+
+ if (present(deriveValue)) then
+ der = deriveValue
+ else
+ der = ppm_poisson_drv_curl_fd4
+ end if
+
+ green = ppm_poisson_grn_pois_per ! periodic boundaries
+ info = -1
+ allocate(fftwplanForppm)
+ ! Call ppm routine to initialize fftw plan.
+ call ppm_poisson_init(topoid,meshid,fftwplanForppm,fieldin,fieldout,green,info,derive=ppm_poisson_drv_curl_fd4)
+ !call mypoisson_init(topoid,meshid,fftwplanForppm,fieldin,fieldout,info)
+
+ if(info.NE.0) stop 'PPM Poisson solver init failed.'
+ end subroutine init_fftw
+
+ !> Interface to ppm poisson solver with fftw
+ subroutine solve_poisson_fftw(fieldin,fieldout,topoid,meshid,ghostsize)
+
+ real(mk), dimension(:,:,:,:,:), pointer :: fieldin, fieldout
+ integer, intent(in) :: meshid, topoid
+ integer, dimension(:),pointer::ghostsize
+
+ integer :: info
+ ! Finite diff scheme used to compute curl
+ !integer :: dtype
+
+ info = -1
+
+ ! Solves laplacian(fieldout) = - fieldin
+ call ppm_poisson_solve(topoid,meshid,fftwplanForppm,fieldin,fieldout,ghostsize,info)
+ !call mypoisson_solve(topoid,meshid,fftwplanForppm,fieldin,fieldout,ghostsize,info)
+ if(info.NE.0) stop 'PPM Poisson solver failed.'
+
+ ! info = -1
+ ! Computes fieldout = curl(fieldout) using finite differences, 2nd order (dtype = ppm_poisson_drv_curl_fd2),
+ ! or 4th order (dtype = ppm_poisson_drv_curl_fd4). Last one is untested according to ppm doc ...
+ ! According to Johannes, not needed if I set derive in poisson_init
+ !call ppm_poisson_fd(topoid,meshid,fieldout,fieldout,dtype,info)
+ !if(info.NE.0) stop 'PPM Poisson, curl computation failed.'
+
+ end subroutine solve_poisson_fftw
+
+ subroutine finalize_poisson_fftw()
+ ! TODO ...
+ ! In ppm nothing is done to free fftw plan or other temp. buffers.
+ end subroutine finalize_poisson_fftw
+
+end module Solver
+
+
diff --git a/HySoP/src/ppmInterface/Topology.f90 b/HySoP/src/ppmInterface/Topology.f90
new file mode 100755
index 0000000000000000000000000000000000000000..77147a660ee6e26b26ceb3816461289557339b49
--- /dev/null
+++ b/HySoP/src/ppmInterface/Topology.f90
@@ -0,0 +1,225 @@
+!> Tools to create and init the topology
+!! Based on ppm
+module client_topology
+
+ use ppm_module_typedef, only : ppm_t_topo
+ use ppm_module_mktopo
+ use ppm_module_topo_get
+ use ppm_module_mesh_define
+ use ppm_module_data, only : ppm_param_assign_internal,ppm_param_decomp_cartesian,ppm_topo,&
+ ppm_param_decomp_xpencil,ppm_param_decomp_ypencil,ppm_param_decomp_zpencil
+
+ use client_data, only : mk,dime,dim3
+ use parmesTools
+
+ implicit none
+
+ !> A pointer to a ppm topology
+ type :: topoPtr
+ !> pointer to ppm topo
+ type(ppm_t_topo), pointer :: ptr
+ !> id of the local mesh on the current topo (Warning : we consider only 1 mesh/topo, at the present time)
+ integer :: meshid
+ end type topoPtr
+
+ !> A pointer to ppm topology object
+ type(ppm_t_topo), pointer :: topo => null()
+ !> Array of 1D topologies for FFTW solvers
+ type(topoPtr), dimension(dime) :: topo1D
+ !> 1D topology for FFTW solvers
+ type(ppm_t_topo), pointer :: topoY => NULL()
+ !> number of sub-domains on the current (mpi)proc. This is for ppm and should be 1 in our case.
+ integer :: nsublist
+ !> number of the current mpi proc according to ppm. May be different from rank and is required.
+ integer :: isubl
+ !> local mesh number
+ integer :: meshNum
+
+ private
+
+ public PPMinitTopo, topo, meshNum, ppm_t_topo, getPPMLocalResolution,nsublist,isubl,createTopologyY,topoY
+
+contains
+
+ !> Create the topology - Based on ppm_topo_mkfield routine (interface = ppm_mktopo)
+ subroutine PPMinitTopo(minPos,maxPos,bc,ghostsize,resolution)
+
+ real(mk), dimension(:),pointer :: minpos,maxpos
+ integer, dimension(:),pointer :: bc
+ integer, dimension(:),pointer :: ghostsize
+ integer, dimension(:),pointer :: resolution
+
+ ! Unused parameter that must be present as an input arg ...
+ real(mk), dimension(:,:),pointer :: false_xp => NULL()
+ real(mk), dimension(:),pointer :: subcost => NULL()
+ integer :: false_np
+ integer assigning, decomposition
+ integer :: info, meshid, topoid
+
+ info = -1
+ topoid=0
+ meshid =-1
+ decomposition = ppm_param_decomp_cartesian
+ assigning = ppm_param_assign_internal
+ false_np = -1 ! Must be negative to have purely mesh-based decomposition
+ ! topology
+ ! Note FP: ghostsize are never used in mktopo for decomp_cartesian.
+ ! Note2 FP: struct topo as input results in failure.
+
+ call ppm_mktopo(topoid,meshid,false_xp,false_np,decomposition,assigning,minPos(1:dime),maxPos(1:dime),bc, &
+ ghostsize,subcost,resolution(1:dime),info)
+ !decomposition = ppm_param_decomp_xy_slab
+ !ghostsize =0.0
+ !CALL ppm_mktopo(topoid,meshid,false_xp,0,decomposition,assigning,minPos,maxPos,bc,&
+ ! ghostsize,subcost,resolution,info)
+
+ !meshid2=-1
+ !nmxyc=resolution
+ !nmxyc(1)=(resolution(1)-1)/2 +1
+ !CALL ppm_mesh_define(topoid,meshid2,nmxyc,istartxyc,ndataxyc,info)
+
+ !print *, 'iaiaaoaioaioa', ppm_topo(topoid)%t%mesh(meshid2)%nnodes
+ if(info.ne.0) stop 'Topology:init initialisation failed'
+
+ ! Get the created topology ...
+ topo=>ppm_topo(topoid)%t
+
+ ! We init ppm numbers for sub domains
+ nsublist=topo%nsublist
+ call parmesAssert(nsublist,1,'there are several sub-domains on the current process and that is not allowed.')
+ !> Number of the current process for ppm. May be different from rank.
+ isubl = topo%isublist(nsublist)
+ !! If we need nsublist > 1, every place where isubl is used should look like :
+ ! do isub=1,nsublist
+ ! isubl=topo%isublist(isub)
+ ! call something(...,isubl,...)
+ ! enddo
+
+ ! we suppose that there is only on mesh created on each subdomain
+ meshNum = topo%max_meshid
+ call parmesAssert(meshNum,1,&
+ 'it seems that several meshes are defined on the current sub-domain, which may result in simulation failure.')
+
+ print *, rank, "AAAAAAAAAAAAAA", shape(topo%mesh(meshNum)%nnodes), "nbnbnb", topo%mesh(meshNum)%nnodes
+
+!!$ call ppm_topo_get_meshinfo(topoid,meshid,nm,istart,ndata,maxndata,isublist,nsublist,info)
+!!$
+!!$ print *, 'nm', nm
+!!$ print *, 'istart', istart
+!!$ print *, 'ndata', ndata
+!!$ print *, 'maxndata',maxndata
+!!$ print *, 'isublist', isublist
+!!$ print *, 'nsublist',nsublist
+ ! Notes Franck:
+ ! nsublist is the number of subdomains for one processus (mpi proc not physical proc ...)
+ ! isublist[i] = global number of the subdomain i (i being the local number)
+ ! Warning: it seems that isublist is of size mpi-number-of proc but only the 1:nsublist elements are relevent
+ ! sub2proc[i] = global number of the processus on which subdomain i is attached
+ !
+!!$
+!! print *, '[', rank,'], subs : ', topo%nsublist, '//', shape(topo%isublist),'//', topo%isublist(1)
+!!$ print *, '======================= [', rank,'] ', shape(topo%sub2proc)
+!!$ print *, '======================= [', rank,'] ', topo%sub2proc
+!!$
+!!$
+!!$ print *, '======================= [', rank,'] ', shape(topo%mesh(1)%nnodes)
+!!$ print *, '======================= [', rank,'] ', topo%mesh(1)%nnodes
+!!$ print *, '======================= [', rank,'] ', shape(topo%mesh(1)%istart)
+!!$ print *, '======================= [', rank,'] ', topo%mesh(1)%Nm
+
+ end subroutine PPMinitTopo
+
+ !> Return the local (mpi) subdomain resolution
+ function getPPMLocalResolution(localTopo,meshid)
+
+ !> topology of interest
+ type(ppm_t_topo), pointer :: localTopo
+ !> id of the mesh from which we need to get the resolution
+ integer, intent(in) :: meshid
+ integer,dimension(dim3) :: getPPMLocalResolution
+
+ getPPMLocalResolution = 1
+ getPPMLocalResolution(1:dime) = maxval(localTopo%mesh(meshid)%nnodes(:,localTopo%isublist(1:localTopo%nsublist)),2)
+
+ end function getPPMLocalResolution
+
+ !> 1D topologies creation, for fftw solvers
+ !!
+ subroutine create1DTopologies(minPos,maxPos,bc,resolution)
+
+ real(mk), dimension(:),pointer :: minpos,maxpos
+ integer, dimension(:),pointer :: bc
+ integer, dimension(:),pointer :: resolution
+
+ ! Unused parameter that must be present as an input arg ...
+ real(mk), dimension(:,:),pointer :: false_xp => NULL()
+ real(mk), dimension(:),pointer :: subcost => NULL()
+ integer :: false_np
+ integer :: assigning
+ integer, dimension(dim3) :: decomposition
+ integer :: info, meshid, topoid,i
+ integer,dimension(dim3), parameter :: zeros = (/0,0,0/)
+
+ info = 0
+ decomposition(c_X) = ppm_param_decomp_xpencil
+ decomposition(c_Y) = ppm_param_decomp_ypencil
+ decomposition(c_Z) = ppm_param_decomp_zpencil
+ assigning = ppm_param_assign_internal
+ false_np = 0 ! Purely mesh-based decomposition
+
+ ! No ghosts for these topologies
+
+ ! loop over dimensions
+ do i=1,dime
+ topoid = 0
+ meshid = -1
+ call ppm_mktopo(topoid,meshid,false_xp,0,decomposition(i),assigning,minpos(1:dime),maxpos(1:dime),bc,&
+ zeros(1:dime),subcost,resolution(1:dime),info)
+ topo1D(i)%ptr=>ppm_topo(topoid)%t
+ topo1D(i)%meshid = meshid
+ end do
+
+ print *,"iijiji", topo1D(c_X)%ptr%mesh(meshid)%nnodes
+
+ end subroutine create1DTopologies
+
+ !> 1D topologies creation, for fftw solvers
+ !!
+ subroutine createTopologyY(topoid,meshid,minPos,maxPos,bc,resolution)
+
+ real(mk), dimension(:),pointer :: minpos,maxpos
+ integer, dimension(:),pointer :: bc
+ integer, dimension(:),pointer :: resolution
+ integer, intent(inout) :: topoid
+ integer, intent(inout) :: meshid
+
+ ! Unused parameter that must be present as an input arg ...
+ real(mk), dimension(:,:),pointer :: false_xp => NULL()
+ real(mk), dimension(:),pointer :: subcost => NULL()
+ integer :: false_np
+ integer :: assigning
+ integer :: decomposition
+ integer :: info
+ integer,dimension(dime), parameter :: zeros = (/0,0/)
+
+ info = 0
+
+ decomposition = ppm_param_decomp_xpencil
+ assigning = ppm_param_assign_internal
+ false_np = 0 ! Purely mesh-based decomposition
+
+ ! No ghosts for these topologies
+ ! loop over dimensions
+ topoid = 0
+ meshid = -1
+ call ppm_mktopo(topoid,meshid,false_xp,0,decomposition,assigning,minpos(1:dime),maxpos(1:dime),bc,&
+ zeros(1:dime),subcost,resolution(1:dime),info)
+ topoY=>ppm_topo(topoid)%t
+
+ print *,rank,"iijiji", topoY%mesh(meshid)%nnodes
+ print *,rank,"iooooooooijiji", getPPMLocalResolution(topoY,meshid)
+
+ end subroutine createTopologyY
+
+
+end module client_topology
diff --git a/HySoP/src/ppmInterface/callCharFunc.f90 b/HySoP/src/ppmInterface/callCharFunc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9ba929739ea6b8cafb589d87b62c7f2393242ca5
--- /dev/null
+++ b/HySoP/src/ppmInterface/callCharFunc.f90
@@ -0,0 +1,39 @@
+!> \file callCharFunc.f90 Wrapper to fortran functions that have a char-type input argument.
+
+!> \brief Module to wrap fortran functions with char arg.
+module charFunctions
+
+ use ppm_module_substart
+ use ppm_module_substop
+
+ implicit none
+
+contains
+
+ !> Wrapper to ppm substart function
+ !! @param[in,out] cpu time when this function is called
+ !! @param[in] error status
+ !! @param[in] Name of the calling-function
+ subroutine start(t0,info,msg)
+
+ real(8) :: t0
+ character(len=*) :: msg
+ integer :: info
+ call substart(msg,t0,info)
+ end subroutine start
+
+ !> Wrapper to ppm substop function : print caller name and cpu time elasped since start call (for the same caller)
+ !! @param[in] cpu time, value returned during substart call
+ !! @param[in] error status
+ !! @param[in] Name of the calling-function
+ subroutine stop(t0,info,msg)
+
+ real(8) :: t0
+ character(len=*) :: msg
+ integer :: info
+
+ call substop(msg,t0,info)
+ end subroutine stop
+
+end module charFunctions
+
diff --git a/HySoP/src/ppmInterface/poisson_init.f90 b/HySoP/src/ppmInterface/poisson_init.f90
new file mode 100755
index 0000000000000000000000000000000000000000..42ad26088b3b3c18cdaa7c42326691da3357cde1
--- /dev/null
+++ b/HySoP/src/ppmInterface/poisson_init.f90
@@ -0,0 +1,597 @@
+module ppmljk_poisson
+
+ use client_data
+ use ppm_module_poisson
+ use ppm_module_mktopo
+ use ppm_module_topo_get
+ use ppm_module_mesh_define
+ use ppm_module_map_field
+ use ppm_module_map_field_global
+ use ppm_module_map
+ use mpi
+
+ implicit none
+
+ integer,dimension(dim3), parameter :: zeros = (/0,0,0/)
+
+ !#define __ZEROSI (/0,0,0/)
+
+contains
+
+ !> Initialisation of Poisson solver (fft), based on ppm and on a copy on the
+ !! equivalent file in ppm
+ subroutine mypoisson_init(topoid,meshid,ppmpoisson,fieldin,fieldout,info)
+!!! * ppm_poisson_grn_pois_per - Poisson equation, periodic boundaries
+!!!
+!!! [NOTE]
+!!! fieldin is not preserved by this routine!
+!!! fieldin and fieldout must NOT be the same fields. In-place FFTs have
+!!! not been implemented.
+!!!
+
+ !> the topology id
+ integer, intent(in) :: topoid
+ !> corresponding mesh id
+ integer, intent(in) :: meshid
+ !> fftw plan interface
+ type(ppm_poisson_plan),intent(out) :: ppmpoisson
+ !> input field (i.e. rhs of poisson eq.)
+ !@ strictly speaking fieldin is not being used in the init routine
+ real(mk), dimension(:,:,:,:,:), pointer :: fieldin
+ !> output field
+ real(mk), dimension(:,:,:,:,:), pointer :: fieldout
+ !> error status
+ integer, intent(out) :: info
+
+ !-------------------------------------------------------------------------
+ ! Local variables
+ !-------------------------------------------------------------------------
+ ! real(mk) :: t0
+ real(mk),dimension(:,:),pointer :: xp=>NULL() !particle positions
+ TYPE(ppm_t_topo),pointer :: topology=>NULL()
+ TYPE(ppm_t_equi_mesh) :: mesh
+ integer ,dimension(dime) :: indl,indu
+ real(mk),PARAMETER :: PI=ACOS(-1.0_mk) !@ use ppm pi
+ real(mk) :: normfac
+!!!factor for the Greens function, including FFT normalization
+ integer :: i,j,k
+ integer :: kx,ky,kz
+ integer :: isubl,isub
+ integer,dimension(dime*2) :: bcdef
+ integer :: assigning
+ integer :: decomposition
+ integer,SAVE :: ttopoid
+ integer :: tmeshid
+ real(mk) :: Lx2,Ly2,Lz2
+
+ real(mk),dimension(dime) :: tmpmin,tmpmax
+ integer, dimension(:),pointer :: maxndataxy=>NULL(),maxndataz=>NULL()
+ integer, dimension(: ), pointer :: dummynmxy=>NULL(),dummynmz=>NULL()
+
+ !-------------------------------------------------------------------------
+ ! Initialise routine
+ !-------------------------------------------------------------------------
+ ! CALL substart('ppm_poisson_init',t0,info)
+
+ ppmpoisson%case = ppm_poisson_grn_pois_per
+
+ !-------------------------------------------------------------------------
+ ! Nullify pointers from the ppmpoisson plans and the fftplans
+ !-------------------------------------------------------------------------
+ NULLIFY(xp)
+ NULLIFY(ppmpoisson%costxy)
+ NULLIFY(ppmpoisson%istartxy)
+ NULLIFY(ppmpoisson%ndataxy)
+ NULLIFY(ppmpoisson%istartxyc)
+ NULLIFY(ppmpoisson%ndataxyc)
+ NULLIFY(ppmpoisson%costz)
+ NULLIFY(ppmpoisson%istartz)
+ NULLIFY(ppmpoisson%ndataz)
+ NULLIFY(ppmpoisson%planfxy%plan)
+ NULLIFY(ppmpoisson%planbxy%plan)
+ NULLIFY(ppmpoisson%planfz%plan)
+ NULLIFY(ppmpoisson%planbz%plan)
+
+ !-------------------------------------------------------------------------
+ ! Get topology and mesh values of input/output
+ !-------------------------------------------------------------------------
+ call ppm_topo_get(topoid,topology,info)
+ mesh = topology%mesh(meshid)
+
+ !-------------------------------------------------------------------------
+ ! Setup mesh sizes for intermediate meshes/topologies
+ !-------------------------------------------------------------------------
+ !size of real slabs
+ ppmpoisson%nmxy (1) = mesh%nm(1)
+ ppmpoisson%nmxy (2) = mesh%nm(2)
+ ppmpoisson%nmxy (3) = mesh%nm(3)
+ !size of complex slabs
+ ppmpoisson%nmxyc(1) = (mesh%nm(1)-1)/2+1
+ !!ppmpoisson%nmxyc(1) = mesh%nm(1)
+ ppmpoisson%nmxyc(2) = mesh%nm(2)
+ ppmpoisson%nmxyc(3) = mesh%nm(3)
+ !size of complex pencils
+ ppmpoisson%nmz (1) = (ppmpoisson%nmxyc(1))
+ ppmpoisson%nmz (2) = (ppmpoisson%nmxyc(2))
+ ppmpoisson%nmz (3) = (ppmpoisson%nmxyc(3))
+ !size of the fft
+ ppmpoisson%nmfft(1) = mesh%nm(1)-1
+ ppmpoisson%nmfft(2) = mesh%nm(2)-1
+ ppmpoisson%nmfft(3) = mesh%nm(3)-1
+ !Inverse of the size of the domain squared
+ Lx2 = 1.0_mk/(topology%max_physd(1)-topology%min_physd(1))**2
+ Ly2 = 1.0_mk/(topology%max_physd(2)-topology%min_physd(2))**2
+ Lz2 = 1.0_mk/(topology%max_physd(3)-topology%min_physd(3))**2
+
+ !-------------------------------------------------------------------------
+ ! Create temporary derivation arrays if necessary
+ !-------------------------------------------------------------------------
+ ppmpoisson%derivatives = ppm_poisson_drv_curl_sp
+
+ !-------------------------------------------------------------------------
+ ! Create spectral scaling components always. Just in case some
+ ! reprojection comes up
+ ! The conditionals need to be for not just the Poisson equation
+ !-------------------------------------------------------------------------
+ ppmpoisson%normkx = &
+ & 2.0_mk*PI/(topology%max_physd(1)-topology%min_physd(1))
+ ppmpoisson%normky = &
+ & 2.0_mk*PI/(topology%max_physd(2)-topology%min_physd(2))
+ ppmpoisson%normkz = &
+ & 2.0_mk*PI/(topology%max_physd(3)-topology%min_physd(3))
+
+ !-------------------------------------------------------------------------
+ ! Create new slab topology
+ !-------------------------------------------------------------------------
+ ttopoid = 0
+ tmeshid = -1
+ decomposition = ppm_param_decomp_xy_slab
+ assigning = ppm_param_assign_internal
+ bcdef = ppm_param_bcdef_periodic
+ tmpmin = topology%min_physd
+ tmpmax = topology%max_physd
+
+ CALL ppm_mktopo(ttopoid,tmeshid,xp,0,&
+ & decomposition,assigning,&
+ & tmpmin,tmpmax,bcdef,&
+ & zeros,ppmpoisson%costxy,&
+ & ppmpoisson%nmxy,info)
+
+ ppmpoisson%topoidxy = ttopoid
+ ppmpoisson%meshidxy = tmeshid
+ !-------------------------------------------------------------------------
+ ! Get additional xy-mesh information
+ !-------------------------------------------------------------------------
+ CALL ppm_topo_get_meshinfo(ppmpoisson%topoidxy,ppmpoisson%meshidxy, &
+ & dummynmxy,ppmpoisson%istartxy,ppmpoisson%ndataxy,maxndataxy, &
+ & ppmpoisson%isublistxy,ppmpoisson%nsublistxy,info)
+
+
+ !-------------------------------------------------------------------------
+ ! Create complex slab mesh
+ !-------------------------------------------------------------------------
+ ttopoid = ppmpoisson%topoidxy
+ tmeshid = -1
+ CALL ppm_mesh_define(ttopoid,tmeshid,&
+ & ppmpoisson%nmxyc,ppmpoisson%istartxyc,ppmpoisson%ndataxyc,info)
+ ppmpoisson%meshidxyc = tmeshid
+
+
+ !-------------------------------------------------------------------------
+ ! Create new pencil topology
+ !-------------------------------------------------------------------------
+ ttopoid = 0
+ tmeshid = -1
+ bcdef = ppm_param_bcdef_periodic
+ assigning = ppm_param_assign_internal
+ decomposition = ppm_param_decomp_zpencil
+
+ CALL ppm_mktopo(ttopoid,tmeshid,xp,0,&
+ & decomposition,assigning,&
+ & tmpmin,tmpmax,bcdef,&
+ & zeros,ppmpoisson%costz,&
+ & ppmpoisson%nmz,info)
+
+ ppmpoisson%topoidz = ttopoid
+ ppmpoisson%meshidz = tmeshid
+ !-------------------------------------------------------------------------
+ ! Get additional z-mesh information
+ !-------------------------------------------------------------------------
+ CALL ppm_topo_get_meshinfo(ppmpoisson%topoidz,ppmpoisson%meshidz, &
+ & dummynmz,ppmpoisson%istartz,ppmpoisson%ndataz,maxndataz, &
+ & ppmpoisson%isublistz,ppmpoisson%nsublistz,info)
+
+ !-------------------------------------------------------------------------
+ ! Set and get minimum and maximum indicies
+ !-------------------------------------------------------------------------
+ indl(1) = 1
+ indl(2) = 1
+ indl(3) = 1
+
+ !-------------------------------------------------------------------------
+ ! Allocate real xy slabs
+ !-------------------------------------------------------------------------
+ ALLOCATE(ppmpoisson%fldxyr(dime,&
+ & indl(1):maxndataxy(1),indl(2):maxndataxy(2),indl(3):maxndataxy(3),&
+ & 1:ppmpoisson%nsublistxy),stat=info)
+
+
+ !-------------------------------------------------------------------------
+ ! Set and get minimum and maximum indicies of COMPLEX xy slabs
+ !-------------------------------------------------------------------------
+ indl(1) = 1
+ indl(2) = 1
+ indl(3) = 1
+ indu(1) = 0
+ indu(2) = 0
+ indu(3) = 0
+ DO isub=1,ppmpoisson%nsublistxy
+ isubl = ppmpoisson%isublistxy(isub)
+ indu(1) = MAX(indu(1),ppmpoisson%ndataxyc(1,isubl))
+ indu(2) = MAX(indu(2),ppmpoisson%ndataxyc(2,isubl))
+ indu(3) = MAX(indu(3),ppmpoisson%ndataxyc(3,isubl))
+ ENDDO
+
+
+ !-------------------------------------------------------------------------
+ ! Allocate complex xy slabs
+ !-------------------------------------------------------------------------
+ ALLOCATE(ppmpoisson%fldxyc(dime,&
+ & indl(1):indu(1),indl(2):indu(2),indl(3):indu(3),&
+ & 1:ppmpoisson%nsublistxy),stat=info)
+
+
+ !-------------------------------------------------------------------------
+ ! Allocate two complex z pencils + Greens fcn array !@check return vars.
+ !-------------------------------------------------------------------------
+ ALLOCATE(ppmpoisson%fldzc1(dime,&
+ & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
+ & 1:ppmpoisson%nsublistz),stat=info)
+
+ ALLOCATE(ppmpoisson%fldzc2(dime,&
+ & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
+ & 1:ppmpoisson%nsublistz),stat=info)
+
+
+ !-------------------------------------------------------------------------
+ ! The complex Greens function is always kept on the z-pencil topology
+ !-------------------------------------------------------------------------
+ ALLOCATE(ppmpoisson%fldgrnr(&
+ & indl(1):maxndataz(1),indl(2):maxndataz(2),indl(3):maxndataz(3),&
+ & 1:ppmpoisson%nsublistz),stat=info)
+
+ !-------------------------------------------------------------------------
+ ! Set up xy FFT plans
+ ! The inverse plan takes the returning topology since it has the full size
+ !-------------------------------------------------------------------------
+ CALL ppm_fft_forward_2d(ppmpoisson%topoidxy,ppmpoisson%meshidxy,&
+ & ppmpoisson%planfxy,ppmpoisson%fldxyr,&
+ & ppmpoisson%fldxyc,info)
+
+ CALL ppm_fft_backward_2d(ppmpoisson%topoidxy,ppmpoisson%meshidxy,&
+ & ppmpoisson%planbxy,ppmpoisson%fldxyc,&
+ & ppmpoisson%fldxyr,info)
+
+
+ !-------------------------------------------------------------------------
+ ! Set up z FFT plans
+ !-------------------------------------------------------------------------
+ CALL ppm_fft_forward_1d(ppmpoisson%topoidz,ppmpoisson%meshidz,&
+ & ppmpoisson%planfz,ppmpoisson%fldzc1,&
+ & ppmpoisson%fldzc2,info)
+
+ CALL ppm_fft_backward_1d(ppmpoisson%topoidz,ppmpoisson%meshidz,&
+ & ppmpoisson%planbz,ppmpoisson%fldzc2,&
+ & ppmpoisson%fldzc1,info)
+
+
+ !-------------------------------------------------------------------------
+ ! Compute Greens function. Analytic, periodic
+ !
+ ! (d2_/dx2 + d2_/dy2 + d2_/dz2)psi = -omega =>
+ ! -4*pi2(kx2 + ky2 + kz2)PSI = -OMEGA =>
+ ! PSI = 1/(4*pi2)*1/(kx2 + ky2 + kz2)OMEGA
+ !-------------------------------------------------------------------------
+ ! Scaling the spectral coefficients...
+ ! one minus due to (i*k)^2 and another due to the Poisson equation
+ normfac = 1.0_mk/(4.0_mk*PI*PI * &
+ !and normalisation of FFTs (full domain) !vertex
+ & real((ppmpoisson%nmfft(1))* &
+ & (ppmpoisson%nmfft(2))* &
+ & (ppmpoisson%nmfft(3)),mk))
+ DO isub=1,ppmpoisson%nsublistz
+ isubl=ppmpoisson%isublistz(isub)
+ DO k=1,ppmpoisson%ndataz(3,isubl)
+ DO j=1,ppmpoisson%ndataz(2,isubl)
+ DO i=1,ppmpoisson%ndataz(1,isubl)
+ kx = i-1 + (ppmpoisson%istartz(1,isubl)-1)
+ ky = j-1 + (ppmpoisson%istartz(2,isubl)-1)
+ kz = k-1 + (ppmpoisson%istartz(3,isubl)-1)
+ !This is a nasty way to do this but it is only done once so...:
+ IF (kx .GT. (ppmpoisson%nmfft(1)/2)) kx = kx-(ppmpoisson%nmfft(1))
+ IF (ky .GT. (ppmpoisson%nmfft(2)/2)) ky = ky-(ppmpoisson%nmfft(2))
+ IF (kz .GT. (ppmpoisson%nmfft(3)/2)) kz = kz-(ppmpoisson%nmfft(3))
+ ppmpoisson%fldgrnr(i,j,k,isub) = &
+ & normfac/(real(kx*kx,mk)*Lx2 &
+ & + real(ky*ky,mk)*Ly2 &
+ & + real(kz*kz,mk)*Lz2)
+ !Take care of singularity
+ !This is nasty as well
+ IF ((kx*kx+ky*ky+kz*kz) .EQ. 0) THEN
+ ppmpoisson%fldgrnr(i,j,k,isub) = 0.0_mk
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ end subroutine mypoisson_init
+
+ subroutine mypoisson_solve(topoid,meshid,ppmpoisson,fieldin,fieldout,gstw,info)
+
+
+ INTEGER, INTENT(IN) :: topoid
+!!! Topology ID
+ INTEGER, INTENT(IN) :: meshid
+!!! Mesh ID
+ TYPE(ppm_poisson_plan),INTENT(INOUT) :: ppmpoisson
+!!! The PPM Poisson plan
+ REAL(mk),DIMENSION(:,:,:,:,:),POINTER :: fieldin
+!!! Input data field
+ REAL(mk),DIMENSION(:,:,:,:,:),POINTER :: fieldout
+!!! Output data field
+ INTEGER,DIMENSION(dime),INTENT(IN) :: gstw
+!!! Ghost layer width
+ INTEGER, INTENT(OUT) :: info
+!!! Return status, 0 upon succes
+
+ !-------------------------------------------------------------------------
+ ! Local variables
+ !-------------------------------------------------------------------------
+
+ REAL(mk) :: t0
+ INTEGER :: isub,isubl
+ INTEGER :: i,j,k
+ INTEGER :: info2
+ INTEGER :: presentcase
+ COMPLEX(mk) :: divomega
+ INTEGER :: gi,gj,gk
+ COMPLEX(mk) :: kx,ky,kz
+ COMPLEX(mk) :: phix,phiy,phiz
+ REAL(mk) :: normfac
+
+ !-------------------------------------------------------------------------
+ ! Check if we run a different/temporary case
+ !-------------------------------------------------------------------------
+
+ presentcase = ppmpoisson%case
+
+ !-----------------------------------------------------------------------
+ ! Map data globally to the slabs (XY)
+ ! This is where the vorticity is extended and padded with 0 for free-space
+ !-----------------------------------------------------------------------
+ !Initialise
+ CALL ppm_map_field_global(topoid,ppmpoisson%topoidxy,meshid,ppmpoisson%meshidxy,info)
+ !Push the data
+ CALL ppm_map_field_push(topoid,meshid,fieldin,3,info)
+ CALL ppm_map_field_send(info)
+ !Retrieve
+ CALL ppm_map_field_pop(ppmpoisson%topoidxy,ppmpoisson%meshidxy,ppmpoisson%fldxyr,3,zeros,info)
+
+ !-----------------------------------------------------------------------
+ ! Do slab FFT (XY) - use the xy topology as its extent has not been halved
+ !-----------------------------------------------------------------------
+ CALL ppm_fft_execute_2d(ppmpoisson%topoidxy,&
+ & ppmpoisson%meshidxy, ppmpoisson%planfxy, &
+ & ppmpoisson%fldxyr, ppmpoisson%fldxyc, &
+ & info)
+
+ !-----------------------------------------------------------------------
+ ! Map to the pencils (Z)
+ !-----------------------------------------------------------------------
+ !Initialise
+ CALL ppm_map_field_global(&
+ & ppmpoisson%topoidxy, &
+ & ppmpoisson%topoidz, &
+ & ppmpoisson%meshidxyc, &
+ & ppmpoisson%meshidz,info)
+
+ !Push the data
+ CALL ppm_map_field_push(&
+ & ppmpoisson%topoidxy, &
+ & ppmpoisson%meshidxyc,ppmpoisson%fldxyc,3,info)
+ !Send
+ CALL ppm_map_field_send(info)
+
+ !Retrieve
+ CALL ppm_map_field_pop(&
+ & ppmpoisson%topoidz, &
+ & ppmpoisson%meshidz,ppmpoisson%fldzc1, &
+ & 3,zeros,info)
+
+ !-----------------------------------------------------------------------
+ ! Do pencil FFT (Z)
+ !-----------------------------------------------------------------------
+ CALL ppm_fft_execute_1d(ppmpoisson%topoidz,&
+ & ppmpoisson%meshidz, ppmpoisson%planfz, &
+ & ppmpoisson%fldzc1, ppmpoisson%fldzc2, &
+ & info)
+
+
+ !-----------------------------------------------------------------------
+ ! Apply the periodic Greens function
+ !-----------------------------------------------------------------------
+ DO isub=1,ppmpoisson%nsublistz
+ isubl=ppmpoisson%isublistz(isub)
+ DO k=1,ppmpoisson%ndataz(3,isubl)
+ DO j=1,ppmpoisson%ndataz(2,isubl)
+ DO i=1,ppmpoisson%ndataz(1,isubl)
+ ppmpoisson%fldzc2(1,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
+ & ppmpoisson%fldzc2(1,i,j,k,isub)
+ ppmpoisson%fldzc2(2,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
+ & ppmpoisson%fldzc2(2,i,j,k,isub)
+ ppmpoisson%fldzc2(3,i,j,k,isub) = ppmpoisson%fldgrnr( i,j,k,isub)*&
+ & ppmpoisson%fldzc2(3,i,j,k,isub)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+
+
+ !-----------------------------------------------------------------------
+ ! Spectral derivatives
+ ! normkx, etc contains 2pi/Lx
+ !-----------------------------------------------------------------------
+ normfac = 1.0_MK/ REAL((ppmpoisson%nmfft(1))* & !vertex
+ & (ppmpoisson%nmfft(2))* &
+ & (ppmpoisson%nmfft(3)),MK)
+ DO isub=1,ppmpoisson%nsublistz
+ isubl=ppmpoisson%isublistz(isub)
+ DO k=1,ppmpoisson%ndataz(3,isubl)
+ gk = k - 1 + (ppmpoisson%istartz(3,isubl)-1)
+ IF (gk .GT. (ppmpoisson%nmfft(3)/2)) gk = gk-(ppmpoisson%nmfft(3))
+ kz = CMPLX(0.0_MK,REAL(gk,MK),MK)*ppmpoisson%normkz
+ DO j=1,ppmpoisson%ndataz(2,isubl)
+ gj = j - 1 + (ppmpoisson%istartz(2,isubl)-1)
+ IF (gj .GT. (ppmpoisson%nmfft(2)/2)) gj = gj-(ppmpoisson%nmfft(2))
+ ky = CMPLX(0.0_MK,REAL(gj,MK),MK)*ppmpoisson%normky
+ DO i=1,ppmpoisson%ndataz(1,isubl)
+ gi = i - 1 + (ppmpoisson%istartz(1,isubl)-1)
+ IF (gi .GT. (ppmpoisson%nmfft(1)/2)) gi = gi-(ppmpoisson%nmfft(1))
+ kx = CMPLX(0.0_MK,REAL(gi,MK),MK)*ppmpoisson%normkx
+
+ phix = ppmpoisson%fldzc2(1,i,j,k,isub)
+ phiy = ppmpoisson%fldzc2(2,i,j,k,isub)
+ phiz = ppmpoisson%fldzc2(3,i,j,k,isub)
+
+ ppmpoisson%fldzc2(1,i,j,k,isub) = (ky*phiz-kz*phiy)
+ ppmpoisson%fldzc2(2,i,j,k,isub) = (kz*phix-kx*phiz)
+ ppmpoisson%fldzc2(3,i,j,k,isub) = (kx*phiy-ky*phix)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+
+ !-----------------------------------------------------------------------
+ ! IFFT pencil (Z)
+ !-----------------------------------------------------------------------
+ CALL ppm_fft_execute_1d(ppmpoisson%topoidz,&
+ & ppmpoisson%meshidz, ppmpoisson%planbz, &
+ & ppmpoisson%fldzc2, ppmpoisson%fldzc1, &
+ & info)
+
+ !-----------------------------------------------------------------------
+ ! Map back to slabs (XY)
+ !-----------------------------------------------------------------------
+ !Initialise
+ CALL ppm_map_field_global(&
+ & ppmpoisson%topoidz, &
+ & ppmpoisson%topoidxy, &
+ & ppmpoisson%meshidz, &
+ & ppmpoisson%meshidxyc,info)
+ !Push the data
+ CALL ppm_map_field_push(&
+ & ppmpoisson%topoidz, &
+ & ppmpoisson%meshidz,ppmpoisson%fldzc1,3,info)
+
+ !Send
+ CALL ppm_map_field_send(info)
+
+ !Retrieve
+ CALL ppm_map_field_pop(&
+ & ppmpoisson%topoidxy, &
+ & ppmpoisson%meshidxyc,ppmpoisson%fldxyc, &
+ & 3,zeros,info)
+
+ !-----------------------------------------------------------------------
+ ! IFFT (XY) use the non-reduced topology
+ !-----------------------------------------------------------------------
+ CALL ppm_fft_execute_2d(ppmpoisson%topoidxy,&
+ & ppmpoisson%meshidxy, ppmpoisson%planbxy, &
+ & ppmpoisson%fldxyc, ppmpoisson%fldxyr, &
+ & info)
+
+
+ !-----------------------------------------------------------------------
+ ! Map back to standard topology (XYZ)
+ !-----------------------------------------------------------------------
+ !Initialise
+ CALL ppm_map_field_global(&
+ & ppmpoisson%topoidxy, &
+ & topoid, &
+ & ppmpoisson%meshidxy, &
+ & meshid,info)
+ !Push the data
+ CALL ppm_map_field_push(&
+ & ppmpoisson%topoidxy, &
+ & ppmpoisson%meshidxy,ppmpoisson%fldxyr,3,info)
+
+ !Send
+ CALL ppm_map_field_send(info)
+
+ !-------------------------------------------------------------------------
+ ! FINAL RETRIEVE - Here we do different things depending on the task
+ ! i.e. the receiver varies
+ !-------------------------------------------------------------------------
+ IF ((ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2 .OR. &
+ & ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4) ) THEN
+ CALL ppm_map_field_pop(&
+ & topoid, &
+ & meshid,ppmpoisson%drv_vr, &
+ & 3,gstw,info)
+ !-------------------------------------------------------------------------
+ ! Ghost the temporary array for derivatives (drv_vr)
+ !-------------------------------------------------------------------------
+ CALL ppm_map_field_ghost_get(topoid,meshid,gstw,info)
+ CALL ppm_map_field_push(topoid,meshid,ppmpoisson%drv_vr,3,info)
+ CALL ppm_map_field_send(info)
+ CALL ppm_map_field_pop(topoid,meshid,ppmpoisson%drv_vr,3,gstw,info)
+
+ ELSE
+ CALL ppm_map_field_pop(&
+ & topoid, &
+ & meshid,fieldout, &
+ & 3,gstw,info)
+ ENDIF
+
+ !-------------------------------------------------------------------------
+ ! Treat ghost layer to make FD stencils work
+ !-------------------------------------------------------------------------
+ IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2) THEN
+ CALL ppm_poisson_extrapolateghost(topoid,meshid,ppmpoisson%drv_vr,&
+ & 2,4,gstw,info)
+ ENDIF
+ IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4 .AND.&
+ & (presentcase .EQ. ppm_poisson_grn_pois_fre)) THEN
+ CALL ppm_poisson_extrapolateghost(topoid,meshid,ppmpoisson%drv_vr,&
+ & 2,4,gstw,info)
+ ENDIF
+
+ !-------------------------------------------------------------------------
+ ! Optionally do derivatives
+ ! Perhaps make ppm_poisson_fd take _none as argument. Then maybe no
+ ! if-statement is required
+ !-------------------------------------------------------------------------
+ IF (presentcase .NE. ppm_poisson_grn_reprojec) THEN
+ IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd2) THEN
+ CALL ppm_poisson_fd(topoid,meshid,ppmpoisson%drv_vr,fieldout,&
+ & ppm_poisson_drv_curl_fd2,info)
+ ENDIF
+ IF (ppmpoisson%derivatives .EQ. ppm_poisson_drv_curl_fd4) THEN
+ CALL ppm_poisson_fd(topoid,meshid,ppmpoisson%drv_vr,fieldout,&
+ & ppm_poisson_drv_curl_fd4,info)
+ ENDIF
+ ENDIF
+
+ !-------------------------------------------------------------------------
+ ! Finally ghost the velocity/stream function field before returning it
+ ! Also extrapolate if freespace
+ !-------------------------------------------------------------------------
+ CALL ppm_map_field_ghost_get(topoid,meshid,gstw,info)
+ CALL ppm_map_field_push(topoid,meshid,fieldout,3,info)
+ CALL ppm_map_field_send(info)
+ CALL ppm_map_field_pop(topoid,meshid,fieldout,3,gstw,info)
+
+ end subroutine mypoisson_solve
+
+
+end module ppmljk_poisson
diff --git a/HySoP/unusedOrObsolet/DiscreteTransportProblem.py b/HySoP/unusedOrObsolet/DiscreteTransportProblem.py
new file mode 100644
index 0000000000000000000000000000000000000000..438e6df5bd567362c12650de1bef39b971964c8c
--- /dev/null
+++ b/HySoP/unusedOrObsolet/DiscreteTransportProblem.py
@@ -0,0 +1,108 @@
+# -*- coding: utf-8 -*-
+"""
+@package Problem
+Problem representation
+"""
+from ..Param import *
+from DiscreteProblem import DiscreteProblem
+
+
+class DiscreteTransportProblem(DiscreteProblem):
+ """
+ Transport problem discrete representation.
+ """
+
+ def __init__(self, advection, domains=None, variables=None, operators=None):
+ """
+ Constructor.
+ Create a transport problem instance.
+
+ @param advection : Advection operator for transport problem.
+ @param domains : Additionals domains.
+ @param variables : Additionnals variables.
+ @param operators : Additionnals operators.
+ """
+ DiscreteProblem.__init__(self)
+ ## Current simulation time
+ self.t = 0
+ ## Advection operator for the transport problem
+ self.advecOp = advection
+ self.addOperator([self.advecOp])
+ if domains != None:
+ self.addDomain(domains)
+ if variables != None:
+ self.addVariable(variables)
+ if operators != None:
+ self.addOperator(operators)
+ ## Splitting informations
+ self.splittingStep = None
+
+ def step(self, dt):
+ [c_step[0].applyOperator(self.t, dt * c_step[1], c_step[2]) for c_step in self.operator_list]
+ self.t += dt
+
+ def solve(self, T, dt):
+ """
+ Solving method.
+ Solve by applying each operators. For a given splitting.
+
+ @param T : Simulation final time.
+ @param dt : Simulation time step.
+ """
+ print "\n=== Solving ==="
+ ite = 0
+ if not self.printer is None:
+ while self.t < T:
+ self.step(dt)
+ ite += 1
+ #print "iteration ", ite, "\t t =", self.t
+ self.printer.printStep()
+ else:
+ while self.t < T:
+ self.step(dt)
+ ite += 1
+ #print "Iteration ", ite, "\t t =", self.t, "\t(No output mode)"
+ print "\n=== End Solving ==="
+ print "\n=== Timings ==="
+ c_time = 0.
+ q_time = 0.
+ s_time = 0.
+ c_flop = 0
+ c_bytes_accessed = 0
+ for op in self.operators:
+ op_compute_time = 0.
+ print "Time :", op
+ for i in xrange(self.domains[0].dimension):
+ print " - direction ", i, " :", op.compute_time[i], "s"
+ op_compute_time += op.compute_time[i]
+ print " - TOTAL ", op_compute_time, "s \t", (op.total_flop / op_compute_time) * 1e-9, "GFlop/s \t", (op.total_bytes_accessed / op_compute_time) * 1e-9, "GB/s"
+ c_time += op_compute_time
+ c_flop += op.total_flop
+ q_time += op.queued_time
+ s_time += op.submit_time
+ c_bytes_accessed += op.total_bytes_accessed
+ print "Computing time : ", c_time, "s \t", (c_flop / c_time) * 1e-9, "GFlop/s \t", (c_bytes_accessed / c_time) * 1e-9, "GB/s"
+ if not self.operators[0].gpu_kernel is None:
+ print "OpenCL queued time : ", q_time, "s"
+ print "OpenCL submit time : ", s_time, "s"
+
+ def __str__(self):
+ """ToString method"""
+ s = "DiscreteTransportProblem (DiscreteProblem) : {0}\n".format(id(self))
+ s += " {0} domains, {1} variables and {2} operators.\n".format(len(self.domains), len(self.variables), len(self.operators))
+ s += " Domains : \n"
+ for d in self.domains:
+ s += str(d)
+ s += "\n Variables : \n"
+ for v in self.variables:
+ s += str(v)
+ s += "\n Operators : \n"
+ for o in self.operators:
+ s += str(o)
+ s += "\n Solver : {0}\n".format(self.solver)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : DiscreteTransportProblem"
+ print DiscreteTransportProblem.__doc__
diff --git a/HySoP/unusedOrObsolet/GPUParticularSolver.py b/HySoP/unusedOrObsolet/GPUParticularSolver.py
new file mode 100644
index 0000000000000000000000000000000000000000..f87f518524d17e4385644487abdf7362d1e619df
--- /dev/null
+++ b/HySoP/unusedOrObsolet/GPUParticularSolver.py
@@ -0,0 +1,245 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+GPU Particular solver description.
+"""
+import os
+import pyopencl as cl
+from ..Param import *
+from ParticularSolver import ParticularSolver
+from ..Domain.ParticleField import ParticleField
+from ..Variable.DiscreteVariable import DiscreteVariable
+from ..Operator.RemeshingDOp import RemeshingDOp
+from ..Operator.TagDOp import TagDOp
+from ..Operator.InterpolationDOp import InterpolationDOp
+from ..Operator.RemeshingDOp import RemeshingDOp
+
+
+class GPUParticularSolver(ParticularSolver):
+ """
+ GPU Particular solver description.
+ Link with differents numericals methods used. Prepare GPU side (memory, kernels, ...)
+ """
+ def __init__(self, problem,
+ ODESolver,
+ InterpolationMethod,
+ RemeshingMethod,
+ splittingMethod='strang',
+ platform_id=0, device_id=0,
+ device_type='gpu',
+ src=None):
+ """
+ Constructor.
+ Create a solver description.
+ """
+ ParticularSolver.__init__(self, problem, ODESolver, InterpolationMethod, RemeshingMethod, splittingMethod)
+ self.parameters_initialization()
+ self.user_src = src
+ #Get platform.
+ self.platform = cl.get_platforms()[platform_id]
+ #Get device.
+ if device_type == 'gpu':
+ self.device = self.platform.get_devices(cl.device_type.GPU)[device_id]
+ else:
+ self.device = self.platform.get_devices()[device_id]
+ print "Running on", self.device.name, "of", self.platform.name, "platform."
+ #Creates GPU Context
+ self.ctx = cl.Context([self.device])
+ #Create CommandQueue on the GPU Context
+ self.queue = cl.CommandQueue(self.ctx, properties=cl.command_queue_properties.PROFILING_ENABLE)
+
+ def parameters_initialization(self):
+ # Modifying domains parameters to fit with float4 or int4 opencl objects
+ self.gpu_shape = tuple(self.grid.elementNumber)
+ padding_float = np.zeros(4 - self.grid.dimension, dtype=dtype_real_gpu)
+ padding_uint = np.zeros(4 - self.grid.dimension, dtype=dtype_integer)
+ self.grid.min = np.concatenate((self.grid.min, padding_float)).astype(dtype_real_gpu)
+ self.grid.max = np.concatenate((self.grid.max, padding_float)).astype(dtype_real_gpu)
+ self.grid.length = np.concatenate((self.grid.length, padding_float)).astype(dtype_real_gpu)
+ self.grid.elementSize = np.concatenate((self.grid.elementSize, padding_float)).astype(dtype_real_gpu)
+ self.grid.elementNumber = np.concatenate((self.grid.elementNumber, padding_uint + 1)).astype(dtype_integer)
+ self.ppos.values.resize(self.gpu_shape, refcheck=False)
+
+ def buffer_allocations(self):
+ self.gpu_used_mem = 0
+ for v in self.discreteProblem.variables:
+ v.values = np.asarray(v.values, dtype=dtype_real_gpu)
+ v.gpu_mem_object = cl.Buffer(self.ctx,
+ cl.mem_flags.READ_WRITE,
+ size=v.values.nbytes
+ )
+ self.gpu_used_mem += v.gpu_mem_object.size
+ print "Allocation " + v.name + " on gpu, size:", v.gpu_mem_object.size * 1e-6, 'MBytes'
+
+ if debug > 0:
+ debug_size = 0
+ self.discreteProblem.advecOp.debug_integer = np.zeros(debug, dtype=dtype_integer)
+ self.discreteProblem.advecOp.debug_integer_buffer = cl.Buffer(
+ self.ctx, cl.mem_flags.READ_WRITE | cl.mem_flags.COPY_HOST_PTR,
+ hostbuf=self.discreteProblem.advecOp.debug_integer)
+ debug_size += self.discreteProblem.advecOp.debug_integer_buffer.size
+ self.discreteProblem.advecOp.debug_float = np.zeros(debug, dtype=dtype_real_gpu)
+ self.discreteProblem.advecOp.debug_float_buffer = cl.Buffer(
+ self.ctx, cl.mem_flags.READ_WRITE | cl.mem_flags.COPY_HOST_PTR,
+ hostbuf=self.discreteProblem.advecOp.debug_float)
+ debug_size += self.discreteProblem.advecOp.debug_float_buffer.size
+ self.gpu_used_mem += debug_size
+ print "Allocation debug buffer on gpu, size:", debug_size, 'B'
+
+ def initialize(self):
+ """
+ Solver initialisation for a given DiscreteProblem.DiscreteProblem.
+
+ @param discreteProblem : Problem to initialize.
+ """
+ # OpenCL Buffer allocations
+ print "\n=== Device memory allocations ==="
+ self.buffer_allocations()
+ p = self.gpu_used_mem * 100 / (self.device.global_mem_size * 1.)
+ print "Total memory allocated on gpu :", self.gpu_used_mem * 1e-6, "MBytes (", p, " % of total available memory)"
+
+ # Kernels creation/compilation
+ print "\n=== Kernel sources compiling ==="
+ f = open(os.path.join(os.path.split(os.path.abspath(__file__))[0], "gpu_src.cl"), 'r')
+ self.gpu_src = "".join(f.readlines())
+ f.close()
+ if not self.user_src is None:
+ f = open(self.user_src, 'r')
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ build_options = "-cl-single-precision-constant -cl-opt-disable"
+ build_options += " -D DIM=" + str(self.dim)
+ build_options += " -D DEBUG=" + str(debug)
+ build_options += " -D MAX_LINE_POINTS=" + str(np.max(self.grid.elementNumber))
+ self.prg = cl.Program(self.ctx, self.gpu_src).build(build_options)
+ print self.prg.get_build_info(self.device, cl.program_build_info.LOG)
+ print self.prg.get_build_info(self.device, cl.program_build_info.OPTIONS)
+ print self.prg.get_build_info(self.device, cl.program_build_info.STATUS)
+
+ for op in self.discreteProblem.operators:
+ for k in self.prg.all_kernels():
+ if op.gpu_kernel_name == k.get_info(cl.kernel_info.FUNCTION_NAME):
+ op.gpu_kernel = self.prg
+ op.gpu_queue = self.queue
+ op.gpu_shape = self.gpu_shape
+
+ print "\n=== Data initialization ==="
+ for v in self.discreteProblem.variables:
+ v_is_init = False
+ print v.name,
+ for i,k in enumerate(self.prg.all_kernels()):
+ if ('init' + v.name) == k.get_info(cl.kernel_info.FUNCTION_NAME):
+ print 'Initialization Kernel found ',
+ evt = eval("self.prg."+"init"+v.name)(self.queue,
+ self.gpu_shape,
+ None,
+ v.gpu_mem_object,
+ dtype_real_gpu(0.),
+ v.domain.min.astype(dtype_real_gpu),
+ v.domain.elementNumber.astype(dtype_integer),
+ v.domain.elementSize.astype(dtype_real_gpu)
+ )
+ self.queue.finish()
+ print 'compute time :', (evt.profile.end - evt.profile.start) * 1e-9, 's',
+ v.contains_data, v_is_init = False, True
+ if not v_is_init:
+ v.init()
+ print '... Done'
+
+ print "\n=== Data Transfers host->device ==="
+ copy_evts = []
+ transfered_size = 0
+ for v in self.discreteProblem.variables:
+ if v.contains_data:
+ print v.name,
+ if v.dimension == self.dim:
+ print "Memoire arrangée",
+ offset = 0
+ evt = cl.enqueue_copy(self.queue, v.gpu_mem_object,
+ v.values[..., 0].ravel(),
+ device_offset=np.long(offset))
+ copy_evts.append(evt)
+ offset += v.values[..., 0].nbytes
+ evt = cl.enqueue_copy(self.queue, v.gpu_mem_object,
+ v.values[..., 1].swapaxes(1, 0).ravel(),
+ device_offset=np.long(offset))
+ copy_evts.append(evt)
+ if self.dim == 3:
+ offset += v.values[..., 1].nbytes
+ evt = cl.enqueue_copy(self.queue, v.gpu_mem_object,
+ v.values[..., 2].swapaxes(1, 0).swapaxes(2, 0).ravel(),
+ device_offset=np.long(offset))
+ copy_evts.append(evt)
+ else:
+ print "Normal layout",
+ evt = cl.enqueue_copy(self.queue, v.gpu_mem_object, v.values)
+ copy_evts.append(evt)
+ print "Transfering", v.values.nbytes * 1e-6, "MBytes ..."
+ transfered_size += v.values.nbytes
+ self.queue.finish()
+ if len(copy_evts)>0:
+ t = 0.
+ for evt in copy_evts:
+ t += (evt.profile.end - evt.profile.start)
+ print "Transfering host -> device :", t * 1e-9, "s \t", transfered_size / t, "GB/s"
+ else:
+ print "No transfers"
+
+ def collect_data(self):
+ self.queue.finish()
+ print "\n=== Data Transfers device->host ==="
+ copy_evts = []
+ transfered_size = 0
+ for v in self.discreteProblem.variables:
+ if v.contains_data:
+ print v.name,
+ if v.dimension == self.dim:
+ print "Memoire arrangée",
+ temp = np.empty(self.gpu_shape, dtype=dtype_real_gpu)
+ offset = 0
+ evt = cl.enqueue_copy(self.queue, temp, v.gpu_mem_object, device_offset=np.long(offset))
+ copy_evts.append(evt)
+ v.values[..., 0] = temp.reshape(self.gpu_shape)
+ offset += temp.nbytes
+ evt = cl.enqueue_copy(self.queue, temp, v.gpu_mem_object, device_offset=np.long(offset))
+ copy_evts.append(evt)
+ v.values[..., 1] = temp.reshape(self.gpu_shape).swapaxes(1, 0)
+ if self.dim == 3:
+ offset += temp.nbytes
+ evt = cl.enqueue_copy(self.queue, temp, v.gpu_mem_object, device_offset=np.long(offset))
+ copy_evts.append(evt)
+ v.values[..., 2] = temp.reshape(self.gpu_shape).swapaxes(2, 0).swapaxes(1, 0)
+ else:
+ print "Normal layout",
+ evt = cl.enqueue_copy(self.queue, v.values, v.gpu_mem_object)
+ copy_evts.append(evt)
+ print "Transfering", v.values.nbytes * 1e-6, "MBytes ..."
+ transfered_size += v.values.nbytes
+ self.queue.finish()
+ t = 0.
+ for evt in copy_evts:
+ t += (evt.profile.end - evt.profile.start)
+ print "Transfering device -> host :", t * 1e-9, "s \t", transfered_size / t, "GB/s"
+
+ def terminate(self):
+ self.queue.finish()
+
+ def __str__(self):
+ """ToString method"""
+ s = "GPU Particular solver "
+ s += "\n - ODESolver : " + str(self.ODESolver)
+ s += "\n - Interpolation : " + str(self.InterpolationMethod)
+ s += "\n - Remeshing : " + str(self.RemeshingMethod)
+ s += "\n - GPU informations : "
+ s += "\n - platform : " + self.platform.name
+ s += " OpenCL version: " + self.platform.version
+ s += "\n - device : " + self.device.name
+ s += " Global Memory available : " + str(self.device.global_mem_size // 1024 // 1024) + " MB ( " + str(self.device.global_mem_size) + " B)"
+ s += "\n Space index max : " + str(self.device.max_work_item_sizes)
+ s += " Max workgroup size : " + str(self.device.max_work_group_size)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : GPUParticularSolver"
+ print GPUParticularSolver.__doc__
diff --git a/HySoP/unusedOrObsolet/GPUParticularSolver_GLRender.py b/HySoP/unusedOrObsolet/GPUParticularSolver_GLRender.py
new file mode 100644
index 0000000000000000000000000000000000000000..24432e7715d14ff791e0137f3a1d700ce878b218
--- /dev/null
+++ b/HySoP/unusedOrObsolet/GPUParticularSolver_GLRender.py
@@ -0,0 +1,276 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+GPU Particular solver description OpenGL rendering.
+"""
+import os
+import sys
+import pyopencl as cl
+from ..Param import *
+from ParticularSolver import ParticularSolver
+from GPUParticularSolver import GPUParticularSolver
+from ..Domain.ParticleField import ParticleField
+from ..Variable.DiscreteVariable import DiscreteVariable
+from ..Operator.RemeshingDOp import RemeshingDOp
+from ..Operator.TagDOp import TagDOp
+from ..Operator.InterpolationDOp import InterpolationDOp
+from ..Operator.RemeshingDOp import RemeshingDOp
+from ..Operator.VolumeDOp import VolumeDOp
+from OpenGL.GL import *
+from OpenGL.GLU import *
+from OpenGL.GLUT import *
+import time
+
+
+class GPUParticularSolver_GLRender(GPUParticularSolver):
+ """
+ GPU Particular solver description.
+ Link with differents numericals methods used. Prepare GPU side (memory, kernels, ...)
+ """
+ def __init__(self, problem,
+ ODESolver,
+ InterpolationMethod,
+ RemeshingMethod,
+ splittingMethod='strang',
+ platform_id=0,
+ device_id=0,
+ device_type='gpu',
+ dt=1.,
+ src=None,
+ endTime=None):
+ """
+ Constructor.
+ Create a solver description.
+ """
+ ParticularSolver.__init__(self, problem, ODESolver, InterpolationMethod, RemeshingMethod, splittingMethod)
+ self.dt = dt
+ self.parameters_initialization()
+ self.user_src = src
+ self.endTime = endTime
+ if not endTime is None:
+ self.endTime += self.dt * 1.5
+
+ self.volume = DiscreteVariable(domain=self.grid, spec=self.gpu_shape[1:], name="Volume")
+ self.volumeDOp = VolumeDOp(self.volume, self.pscal,
+ np.prod(self.grid.elementSize[0:self.dim]), level=0.5)
+ self.discreteProblem.addOperator(self.volumeDOp)
+ self.discreteProblem.operator_list.append((self.volumeDOp, 1.0, 0))
+
+ glutInit(sys.argv)
+ glutInitWindowSize(self.width, self.height)
+ glutInitWindowPosition(0, 0)
+ glutCreateWindow('OpenCL/OpenGL Parmepy (' + str(np.prod(self.grid.elementNumber[0:self.grid.dimension])) + ' particles)')
+
+ from pyopencl.tools import get_gl_sharing_context_properties
+ if sys.platform == "darwin":
+ self.ctx = cl.Context(properties=get_gl_sharing_context_properties(),
+ devices=[])
+ else:
+ # Some OSs prefer clCreateContextFromType, some prefer
+ # clCreateContext. Try both.
+ try:
+ self.ctx = cl.Context(properties=[
+ (cl.context_properties.PLATFORM, platform)]
+ + get_gl_sharing_context_properties())
+ except:
+ self.ctx = cl.Context(properties=[
+ (cl.context_properties.PLATFORM, platform)]
+ + get_gl_sharing_context_properties(),
+ devices=[platform.get_devices()[0]])
+ self.device = self.ctx.devices[0]
+ self.queue = cl.CommandQueue(self.ctx, properties=cl.command_queue_properties.PROFILING_ENABLE)
+
+ self.points = DiscreteVariable(domain=self.parts, dimension=self.dim)
+ self.points.values = np.asarray(self.points.values, dtype=dtype_real_gpu)
+ self.vbo_points = glGenBuffers(1)
+ glBindBuffer(GL_ARRAY_BUFFER, self.vbo_points)
+ glBufferData(GL_ARRAY_BUFFER, self.points.values.nbytes, None, GL_STREAM_DRAW)
+ glEnableClientState(GL_VERTEX_ARRAY)
+ glVertexPointer(self.dim, GL_FLOAT, 0, None)
+
+ self.pcolor = DiscreteVariable(domain=self.parts, dimension=4)
+ self.pcolor.values = np.asarray(self.pcolor.values, dtype=dtype_real_gpu)
+ self.vbo_color = glGenBuffers(1)
+ glBindBuffer(GL_ARRAY_BUFFER, self.vbo_color)
+ glBufferData(GL_ARRAY_BUFFER, self.pcolor.values.nbytes, None, GL_STREAM_DRAW)
+ glEnableClientState(GL_COLOR_ARRAY)
+ glColorPointer(4, GL_FLOAT, 0, None)
+
+ def parameters_initialization(self):
+ GPUParticularSolver.parameters_initialization(self)
+ #mouse handling for transforming scene
+ self.mouse_down = False
+ self.mouse_old = np.array([0., 0.])
+ self.rotate = np.array([0., 0., 0.])
+ self.translate = -(self.grid.min + self.grid.length / 2.)[0:3]
+ self.initrans = np.array([0., 0., -2.])
+ self.width, self.height = 800, 800
+
+ def buffer_allocations(self):
+ GPUParticularSolver.buffer_allocations(self)
+ # GL buffer allocation
+ self.points.gpu_mem_object = cl.GLBuffer(self.ctx,
+ cl.mem_flags.READ_WRITE,
+ int(self.vbo_points))
+ self.gpu_used_mem += self.ppos.gpu_mem_object.size
+ print "Allocation points colors to render, size:", self.ppos.gpu_mem_object.size, 'B'
+ self.pcolor.gpu_mem_object = cl.GLBuffer(self.ctx,
+ cl.mem_flags.READ_WRITE,
+ int(self.vbo_color))
+ self.gpu_used_mem += self.pscal.gpu_mem_object.size
+ print "Allocation particles color on gpu, size:", self.pscal.gpu_mem_object.size, 'B'
+ self.gl_objects = [self.points.gpu_mem_object, self.pcolor.gpu_mem_object]
+
+###GL CALLBACKS
+ def timer(self, t):
+ glutTimerFunc(t, self.timer, t)
+ glutPostRedisplay()
+
+ def on_key(self, *args):
+ ESCAPE = '\033'
+ if args[0] == ESCAPE or args[0] == 'q':
+ sys.exit()
+
+ def on_click(self, button, state, x, y):
+ if state == GLUT_DOWN:
+ self.mouse_down = True
+ self.button = button
+ else:
+ self.mouse_down = False
+ self.mouse_old[0] = x
+ self.mouse_old[1] = y
+
+ def on_mouse_motion(self, x, y):
+ dx = x - self.mouse_old[0]
+ dy = y - self.mouse_old[0]
+ if self.mouse_down and self.button == 0: # left button
+ self.rotate[0] += dy * .02
+ self.rotate[1] += dx * .02
+ elif self.mouse_down and self.button == 2: # right button
+ self.translate[2] -= dy * .001
+ self.mouse_old[0] = x
+ self.mouse_old[1] = y
+ ###END GL CALLBACKS
+
+ def display(self):
+ if self.endTime is None or (not self.endTime is None and self.discreteProblem.t <= self.endTime):
+ cl.enqueue_acquire_gl_objects(self.queue, self.gl_objects)
+ display_step = time.time() - self.display_clock
+ self.display_clock = time.time()
+ t = time.time()
+ self.discreteProblem.step(self.dt)
+ l = list(self.gpu_shape)
+ splitting_dir = 1
+ nb_ligne = l.pop(splitting_dir)
+ self.prg.colorize(self.queue, tuple(l), None,
+ self.pscal.gpu_mem_object,
+ self.pcolor.gpu_mem_object,
+ self.points.gpu_mem_object,
+ dtype_integer(splitting_dir),
+ dtype_integer(nb_ligne),
+ self.grid.min,
+ self.grid.elementNumber.astype(dtype_integer),
+ self.grid.elementSize
+ )
+ glutSetWindowTitle("OpenCL/OpenGL Parmepy T={0:8.4f} ( {1} particles)".format(
+ self.discreteProblem.t, np.prod(self.grid.elementNumber[0:self.grid.dimension])))
+ cl.enqueue_release_gl_objects(self.queue, self.gl_objects)
+ self.queue.finish()
+ print "Compute time :", (time.time() - t) * 1e3, "ms, \t over ", display_step * 1e3, "ms, \t", 1. / (time.time() - t), "fps"
+
+ glFlush()
+ glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT)
+ glMatrixMode(GL_MODELVIEW)
+ glLoadIdentity()
+
+ #handle mouse transformations
+ glTranslatef(self.initrans[0], self.initrans[1], self.initrans[2])
+ glRotatef(self.rotate[0], 1, 0, 0)
+ glRotatef(self.rotate[1], 0, 1, 0) # we switched around the axis so make this rotate_z
+ glTranslatef(self.translate[0], self.translate[1], self.translate[2])
+
+ glEnable(GL_POINT_SMOOTH)
+ glPointSize(1)
+ glEnable(GL_BLEND)
+ glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
+
+ glBindBuffer(GL_ARRAY_BUFFER, self.vbo_color)
+ glColorPointer(4, GL_FLOAT, 0, None)
+ glBindBuffer(GL_ARRAY_BUFFER, self.vbo_points)
+ glVertexPointer(self.dim, GL_FLOAT, 0, None)
+
+ glEnableClientState(GL_VERTEX_ARRAY)
+ glEnableClientState(GL_COLOR_ARRAY)
+ glDrawArrays(GL_POINTS, 0, np.prod(self.gpu_shape))
+ glDisableClientState(GL_COLOR_ARRAY)
+ glDisableClientState(GL_VERTEX_ARRAY)
+
+ #glDisable(GL_BLEND)
+ orig = np.array([0, 0, 0])
+ x_one = np.array([1, 0, 0])
+ y_one = np.array([0, 1, 0])
+ z_one = np.array([0, 0, 1])
+ glColor3f(1, 0, 0) # red
+ self.draw_line(orig, x_one)
+ glColor3f(0, 1, 0) # green
+ self.draw_line(orig, y_one)
+ glColor3f(0, 0, 1) # blue
+ self.draw_line(orig, z_one)
+
+ def draw_line(self, v1, v2):
+ glBegin(GL_LINES)
+ glVertex3f(v1[0], v1[1], v1[2])
+ glVertex3f(v2[0], v2[1], v2[2])
+ glEnd()
+
+ def initialize(self):
+ """
+ Solver initialisation for a given DiscreteProblem.DiscreteProblem.
+
+ @param discreteProblem : Problem to initialize.
+ """
+ GPUParticularSolver.initialize(self)
+
+ glutDisplayFunc(self.display)
+ glViewport(0, 0, self.width, self.height)
+ glMatrixMode(GL_PROJECTION)
+ glLoadIdentity()
+ gluPerspective(np.max(self.grid.length) * 30., self.width / float(self.height), 0.1, 4.)
+ glMatrixMode(GL_MODELVIEW)
+
+ #handle user input
+ glutKeyboardFunc(self.on_key)
+ glutMouseFunc(self.on_click)
+ glutMotionFunc(self.on_mouse_motion)
+
+ #this will call draw every 10ms
+ self.display_clock = time.time()
+ self.display_time_step = 10
+ glutTimerFunc(self.display_time_step, self.timer, self.display_time_step)
+
+ glClearColor(1, 1, 1, 1)
+ glColor(0, 0, 1)
+
+ print "\n=== Solving ==="
+ print "Début de la boucle GLUT. ('q' ou 'ESC' pour quiter)"
+ self.discreteProblem.solve = glutMainLoop()
+
+ def __str__(self):
+ """ToString method"""
+ s = "GPU Particular solver OpenGL rendering"
+ s += "\n - ODESolver : " + str(self.ODESolver)
+ s += "\n - Interpolation : " + str(self.InterpolationMethod)
+ s += "\n - Remeshing : " + str(self.RemeshingMethod)
+ s += "\n - GPU informations : "
+ s += "\n - platform : " + self.platform.name
+ s += " OpenCL version: " + self.platform.version
+ s += "\n - device : " + self.device.name
+ s += " Global Memory available : " + str(self.device.global_mem_size // 1024 // 1024) + " MB ( " + str(self.device.global_mem_size) + " B)"
+ s += "\n Space index max : " + str(self.device.max_work_item_sizes)
+ s += " Max workgroup size : " + str(self.device.max_work_group_size)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : GPUParticularSolver_GLRender"
+ print GPUParticularSolver_GLRender.__doc__
diff --git a/HySoP/unusedOrObsolet/InterpolationDOp.py b/HySoP/unusedOrObsolet/InterpolationDOp.py
new file mode 100644
index 0000000000000000000000000000000000000000..de3db03b0515a1805beec7b3f9f16394f8a49dc9
--- /dev/null
+++ b/HySoP/unusedOrObsolet/InterpolationDOp.py
@@ -0,0 +1,76 @@
+# -*- coding: utf-8 -*-
+"""
+@package Operator
+Operator representation
+"""
+from ..Param import *
+from DiscreteOperator import DiscreteOperator
+import time
+
+
+class InterpolationDOp(DiscreteOperator):
+ """
+ Interpolation operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, position, velocityField, resvelo, method):
+ """
+ Constructor.
+ Create a Interpolation operator on a given discrete domain.
+ Work on a position to interpolate velocity from a grid.
+
+ @param position : particles positions.
+ @param velocityField : grid velocity.
+ @param resvelo DiscreteVariable.DiscreteVariable : new velocity
+ @param method : Numerical method.
+ """
+ DiscreteOperator.__init__(self)
+ ## Particles positions.
+ self.ppos = position
+ ## Grid velocity values.
+ self.gvelo = velocityField
+ ## Particles velocity
+ self.resultVelocity = resvelo
+ self.addVariable([self.ppos, self.gvelo, self.resultVelocity])
+ self.numMethod = method
+ self.compute_time = 0.
+ self.queued_time = 0.
+ self.submit_time = 0.
+ self.total_flop = 0
+
+ def setResultVariable(self, resvelo):
+ """
+ Set results variables
+
+ @param resvelo DiscreteVariable.DiscreteVariable : new velocity
+ """
+ ## Particles velocity
+ self.resultVelocity = resvelo
+ self.addVariable([self.resultVelocity])
+
+ def applyOperator(self, t, dt, splittingDirection):
+ """
+ Apply advection operator.
+
+ @param t : current time.
+ @param dt : time step for advection.
+ @param splittingDirection : direction to advect.
+ """
+ #for i in self.gvelo.domain.explore():
+ # self.resultVelocity.values[i] = self.numMethod.interpolate(t, self.ppos.values[i], splittingDirection)
+ c_time = time.time()
+ ## ------------------- NumPy Optimisation
+ self.resultVelocity.values = self.numMethod.interpolate(t, self.ppos.values, splittingDirection)
+ ## -------------------
+ self.compute_time += (time.time() - c_time)
+ self.total_flop += self.numMethod.nb_flop * np.prod(self.gvelo.values.shape[0:-1])
+
+ def __str__(self):
+ """ToString method"""
+ return "InterpolationDOp (DiscreteOperator)"
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : InterpolationDOp"
+ print InterpolationDOp.__doc__
diff --git a/HySoP/unusedOrObsolet/ParticleField.py b/HySoP/unusedOrObsolet/ParticleField.py
new file mode 100644
index 0000000000000000000000000000000000000000..9b9d576445e77157ca92905e494ed346aef2f6d8
--- /dev/null
+++ b/HySoP/unusedOrObsolet/ParticleField.py
@@ -0,0 +1,45 @@
+# -*- coding: utf-8 -*-
+"""
+@package Domain
+Physical domain representation.
+"""
+from ..Param import *
+from DiscreteDomain import DiscreteDomain
+
+
+class ParticleField(DiscreteDomain):
+ """
+ Particle field.
+ DiscreteDomain.DiscreteDomain specialization.
+ """
+
+ def __init__(self, grid):
+ """
+ Constructor.
+ Create a list of Particle from each node of a given grid.
+
+ @param grid Grid.Grid : grid to create Particles from
+ """
+ DiscreteDomain.__init__(self, grid.dimension)
+ self.elementNumber = np.copy(grid.elementNumber)
+
+ def setPositions(self, ppos):
+ """
+ Set positions as variable.
+ Change exploring method.
+
+ @param ppos : position variable.
+ """
+ self.positions = ppos.values
+
+ def __str__(self):
+ """
+ ToString method.
+ """
+ s = "ParticleField of " + str(np.prod(self.elementNumber)) + " Particles"
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : ParticleField"
+ print ParticleField.__doc__
diff --git a/HySoP/unusedOrObsolet/TagDOp.py b/HySoP/unusedOrObsolet/TagDOp.py
new file mode 100644
index 0000000000000000000000000000000000000000..5b2ae2e3d65f7162e892ad8586a3d2701475ff3a
--- /dev/null
+++ b/HySoP/unusedOrObsolet/TagDOp.py
@@ -0,0 +1,158 @@
+# -*- coding: utf-8 -*-
+"""
+@package Operator
+Operator representation
+"""
+from DiscreteOperator import DiscreteOperator
+
+providedClass = "TagDOp"
+
+
+class TagDOp(DiscreteOperator):
+ """
+ Tag operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, partPositions, partVelocities, grid, resbloc, restag):
+ """
+ Constructor.
+ Create a Tag operator.
+ Work on given particles positions and velocities to compute particles' type and tag.
+
+ @param ppos : particles positions.
+ @param pvelo : particles velocities.
+ @param grid : underlying grid.
+ @param resbloc DiscreteVariable.DiscreteVariable : particles bloc type.
+ @param restag DiscreteVariable.DiscreteVariable : particles tag.
+ """
+ DiscreteOperator.__init__(self)
+ ## Particles positions.
+ self.ppos = partPositions
+ ## Particles velocities.
+ self.pvelo = partVelocities
+ ## grid
+ self.grid = grid
+ ## Tag
+ self.resultTag = restag
+ ## Bloc
+ self.resultBloc = resbloc
+ self.addVariable([self.ppos, self.pvelo, self.resultBloc, self.resultTag])
+
+ def setResultVariable(self, resbloc, restag):
+ """
+ Set results variables
+
+ @param resbloc DiscreteVariable.DiscreteVariable : particles bloc type.
+ @param restag DiscreteVariable.DiscreteVariable : particles tag.
+ """
+ ## Tag
+ self.resultTag = restag
+ ## Bloc
+ self.resultBloc = resbloc
+ self.addVariable([self.resultBloc, self.resultTag])
+
+ def _nint(self, x):
+ """
+ Nearest interger function.
+
+ @param x : real number.
+ @return : x nearest integer.
+ """
+ if x > -0.5:
+ return int(x + 0.5)
+ else:
+ return int(x + 0.5) - 1
+
+ def applyOperator(self, t, dt, splittingDirection):
+ """
+ Apply advection operator.
+ """
+ #Used dimension
+ d = splittingDirection
+ bloc_size = 2
+ for line in self.grid.explore(d):
+ nb_bloc = len(line) / bloc_size
+ d_bloc = bloc_size * self.grid.elementSize[d]
+ eps_bl = self.grid.elementSize[d] * 0.000000001
+ cfl = dt / self.grid.elementSize[d]
+ max_V = self.pvelo.values[line[0]][d]
+ for i in line:
+ if max_V < self.pvelo.values[i][d]:
+ max_V = self.pvelo.values[i][d]
+ bl_nbPart = [0 for i in xrange(nb_bloc)]
+ bl_type = [0 for i in xrange(nb_bloc)]
+ bl_ind = [0 for i in xrange(nb_bloc)]
+ bl_final_ind = [0 for i in xrange(nb_bloc)]
+ bl_lambdaMin = [max_V * cfl for i in xrange(nb_bloc)]
+ p_ind_bl = {}
+ for i in line:
+ self.resultBloc.values[i] = 0
+ self.resultTag.values[i] = -1
+ # Update bloc infos
+ for i in line:
+ ind_bl = int((self.grid.points[i][d] - self.grid.min[d] + eps_bl) / d_bloc)
+ bl_lambdaMin[ind_bl] = min([bl_lambdaMin[ind_bl], self.pvelo.values[i][d] * cfl])
+ bl_nbPart[ind_bl] += 1
+ bl_final_ind[ind_bl] = i
+ # Compute bl_lambdaMin from next bloc
+ for i in xrange(nb_bloc - 1):
+ ind = tuple([bl_final_ind[i][dd] + 1 if dd == d else bl_final_ind[i][dd] for dd in xrange(len(line[0]))])
+ bl_lambdaMin[i] = min([bl_lambdaMin[i], self.pvelo.values[ind][d] * cfl])
+ # Last bloc
+ bl_lambdaMin[nb_bloc - 1] = min([bl_lambdaMin[nb_bloc - 1], self.pvelo.values[line[0]][d] * cfl])
+ # Bloc type
+ for i in xrange(nb_bloc):
+ ind = self._nint(bl_lambdaMin[i])
+ #print i, ind, bl_lambdaMin[i]
+ if bl_lambdaMin[i] - ind + eps_bl < 0.:
+ # Center bloc
+ #print "Centré"
+ bl_type[i] = 1
+ bl_ind[i] = ind + 1
+ else:
+ # Left bloc
+ #print "Gauche"
+ bl_type[i] = 0
+ bl_ind[i] = ind
+ # Update particles results
+ for i in line:
+ ind_bl = int((self.grid.points[i][d] - self.grid.min[d] + eps_bl) / d_bloc)
+ p_ind_bl[i] = bl_ind[ind_bl]
+ self.resultBloc.values[i] = bl_type[ind_bl]
+ for i in xrange(len(line) - 1):
+ if self.resultTag.values[line[i]] == -1 and (line[i][d] < (self.resultTag.domain.elementNumber[d] - 1)) and line[i][d] > 0:
+ if (p_ind_bl[line[i]] != p_ind_bl[line[i + 1]]) and (self.resultBloc.values[line[i]] != self.resultBloc.values[line[i + 1]]):
+ # tag particle i and i+1
+ print "Tag de la particule", line[i], "et", line[i + 1]
+ self.resultTag.values[line[i]] = 1
+ self.resultTag.values[line[i + 1]] = 2
+ else:
+ # No tag particle i
+ self.resultTag.values[line[i]] = 0
+ if (p_ind_bl[line[0]] != p_ind_bl[line[-1]]) and (self.resultBloc.values[line[0]] != self.resultBloc.values[line[-1]]):
+ # tag particle 0 and -1
+ print "Tag de la particule", line[0], "et", line[-1]
+ self.resultTag.values[line[0]] = 2
+ self.resultTag.values[line[-1]] = 1
+ else:
+ # No tag particle 0 and -1
+ self.resultTag.values[line[0]] = 0
+ self.resultTag.values[line[-1]] = 0
+
+ def __str__(self):
+ """ToString method"""
+ s = "TagDOp (DiscreteOperator) : {0} \n".format(id(self))
+ s += " particles positions = {0}, particles scalar = {1}\n".format(id(self.ppos), id(self.pscal))
+ s += " Variables : \n"
+ for v in self.variables:
+ s += str(id(v)) + "\n"
+ s += " Domains : \n"
+ for d in self.domains:
+ s += str(id(d)) + "\n"
+ return s + "\n"
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
diff --git a/HySoP/unusedOrObsolet/VelocityDOp.py b/HySoP/unusedOrObsolet/VelocityDOp.py
new file mode 100644
index 0000000000000000000000000000000000000000..b35a362a413c9cba9b8ec620d4844e6065d33635
--- /dev/null
+++ b/HySoP/unusedOrObsolet/VelocityDOp.py
@@ -0,0 +1,83 @@
+# -*- coding: utf-8 -*-
+"""
+@package Operator
+Operator representation
+"""
+from ..Param import *
+from DiscreteOperator import DiscreteOperator
+import time
+import pyopencl as cl
+
+providedClass = "VelocityDOp"
+
+
+class VelocityDOp(DiscreteOperator):
+ """
+ Advection operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, velo_op):
+ """
+ Constructor.
+ Create a Transport operator on a given continuous domain.
+ Work on a given scalar at a given velocity to produce scalar distribution at new positions.
+
+ @param advec : Advection operator.
+ """
+ DiscreteOperator.__init__(self)
+ self.is_splittable = False
+ ## Velocity.
+ self.velocity = velo_op.velocity.discreteVariable
+ ## Transported scalar.
+ self.formula = velo_op.formula
+ self.period = velo_op.period
+ self.addVariable([self.velocity])
+ self.gpu_kernel_name = "velocity"
+ self.compute_time = [0., 0., 0.]
+ self.submit_time = 0.
+ self.queued_time = 0.
+ self.total_flop = 0
+ self.total_bytes_accessed = 0
+
+ def applyOperator(self, t, dt, splittingDirection):
+ """
+ Apply advection operator.
+
+ @param t : current time.
+ @param dt : time step for advection.
+ @param splittingDirection : direction to advect.
+ """
+ if self.gpu_kernel is None:
+ raise NotImplementedError("No implementation for velocity opérator on CPU.")
+ else:
+ evt = self.gpu_kernel.velocity(self.gpu_queue, tuple(self.gpu_shape), None,
+ self.velocity.gpu_mem_object,
+ dtype_real_gpu(t), dtype_real_gpu(self.period),
+ self.velocity.domain.min.astype(dtype_real_gpu),
+ self.velocity.domain.elementNumber.astype(dtype_integer),
+ self.velocity.domain.elementSize.astype(dtype_real_gpu)
+ )
+ # self.gpu_queue.finish()
+ # cl.enqueue_copy(self.gpu_queue, self.resultPosition.values, self.resultPosition.gpu_mem_object)
+ # print self.resultPosition.values
+ self.gpu_queue.finish()
+ #temp_tab = np.zeros_like(self.velocity.values)
+ #cl.enqueue_copy(self.gpu_queue, temp_tab, self.velocity.gpu_mem_object)
+ #self.gpu_queue.finish()
+ #print temp_tab
+ self.queued_time += (evt.profile.submit - evt.profile.queued) * 1e-9
+ self.submit_time += (evt.profile.start - evt.profile.submit) * 1e-9
+ self.compute_time[splittingDirection] += (evt.profile.end - evt.profile.start) * 1e-9
+ self.total_flop += 32 * np.prod(self.gpu_shape)
+ self.total_bytes_accessed += 4 * 2 * np.prod(self.gpu_shape)
+ #print "Advection:", self.compute_time * 1e-9
+
+ def __str__(self):
+ """ToString method"""
+ return "VelocityDOp (DiscreteOperator)"
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : VelocityDOp"
+ print VelocityDOp.__doc__
diff --git a/HySoP/unusedOrObsolet/VelocityOp.py b/HySoP/unusedOrObsolet/VelocityOp.py
new file mode 100644
index 0000000000000000000000000000000000000000..18c5ffbb533e400e8b3da9752f793d69c9f769d3
--- /dev/null
+++ b/HySoP/unusedOrObsolet/VelocityOp.py
@@ -0,0 +1,50 @@
+# -*- coding: utf-8 -*-
+"""
+@package Operator
+Operator representation
+"""
+from ..Param import *
+from ContinuousOperator import ContinuousOperator
+from VelocityDOp import VelocityDOp
+
+
+class VelocityOp(ContinuousOperator):
+ """
+ Velocity operator representation
+ """
+
+ def __init__(self, velocity, formula=None, period=10.):
+ """
+ Constructor.
+ Create an Velocity operator from given variables velocity and scalar.
+
+ @param velocity ContinuousVariable.ContinuousVariable : velocity variable.
+ @param scalar ContinuousVariable.ContinuousVariable : scalar variable.
+ """
+ ContinuousOperator.__init__(self)
+ ## advection velocity variable
+ self.velocity = velocity
+ ## advected scalar variable
+ self.formula = formula
+ self.period = period
+ self.addVariable([self.velocity])
+
+ def discretize(self, spec=None):
+ """
+ Velocity operator discretization method.
+ Create an VelocityDOp.VelocityDOp from given specifications.
+
+ @param spec : discretization specifications, not used.
+ """
+ if self.discreteOperator is None:
+ self.discreteOperator = VelocityDOp(self)
+
+ def __str__(self):
+ """ToString method"""
+ s = " Velocity operator (ContinuousOperator)"
+ return s + "\n"
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : VelocityOp"
+ print VelocityOp.__doc__
diff --git a/HySoP/unusedOrObsolet/VolumeDOp.py b/HySoP/unusedOrObsolet/VolumeDOp.py
new file mode 100644
index 0000000000000000000000000000000000000000..f21cf0a6a7f51e0249228bd66c0ffc2b87d98d68
--- /dev/null
+++ b/HySoP/unusedOrObsolet/VolumeDOp.py
@@ -0,0 +1,102 @@
+# -*- coding: utf-8 -*-
+"""
+@package Operator
+Operator representation
+"""
+from ..Param import *
+from DiscreteOperator import DiscreteOperator
+import time
+import pyopencl as cl
+import pylab as pl
+
+providedClass = "VolumeDOp"
+
+
+class VolumeDOp(DiscreteOperator):
+ """
+ Advection operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, volume, pscal, pvolume, level=0.5, filename='./volume.dat'):
+ """
+ Constructor.
+ Create a Transport operator on a given continuous domain.
+ Work on a given scalar at a given velocity to produce scalar distribution at new positions.
+
+ @param advec : Advection operator.
+ """
+ DiscreteOperator.__init__(self)
+ self.is_splittable = False
+ ## Volume.
+ self.volume = volume
+ self.pscal = pscal
+ self.pvolume = pvolume
+ self.addVariable([self.volume, self.pscal])
+ self.level = level
+ self.volume_evolution = []
+ self.gpu_kernel_name = "volume"
+ self.compute_time = [0., 0., 0.]
+ self.submit_time = 0.
+ self.queued_time = 0.
+ self.total_flop = 0
+ self.total_bytes_accessed = 0
+ self.file = open(filename, 'w', 1)
+
+ def applyOperator(self, t, dt, splittingDirection):
+ """
+ Apply advection operator.
+
+ @param t : current time.
+ @param dt : time step for advection.
+ @param splittingDirection : direction to advect.
+ """
+ if self.gpu_kernel is None:
+ raise NotImplementedError("No implementation for velocity opérator on CPU.")
+ else:
+ l = list(self.gpu_shape)
+ nb_ligne = l.pop(splittingDirection)
+ if debug == 0:
+ evt = self.gpu_kernel.volume(self.gpu_queue, tuple(l), None,
+ self.pscal.gpu_mem_object,
+ self.volume.gpu_mem_object,
+ dtype_real_gpu(self.level), dtype_real_gpu(self.pvolume), dtype_integer(splittingDirection), dtype_integer(nb_ligne),
+ self.volume.domain.min.astype(dtype_real_gpu),
+ self.volume.domain.length.astype(dtype_real_gpu),
+ self.volume.domain.elementNumber.astype(dtype_integer),
+ self.volume.domain.elementSize.astype(dtype_real_gpu)
+ )
+ else:
+ evt = self.gpu_kernel.volume(self.gpu_queue, tuple(l), None,
+ self.pscal.gpu_mem_object,
+ self.volume.gpu_mem_object,
+ self.debug_float_buffer, self.debug_integer_buffer,
+ dtype_real_gpu(self.length), dtype_real_gpu(self.pvolume), dtype_integer(splittingDirection), dtype_integer(nb_ligne),
+ self.volume.domain.min.astype(dtype_real_gpu),
+ self.volume.domain.length.astype(dtype_real_gpu),
+ self.volume.domain.elementNumber.astype(dtype_integer),
+ self.volume.domain.elementSize.astype(dtype_real_gpu)
+ )
+ self.gpu_queue.finish()
+ cl.enqueue_copy(self.gpu_queue, self.volume.values, self.volume.gpu_mem_object)
+ self.file.write(str(self.volume.values.sum()) + '\n')
+ if debug > 0:
+ cl.enqueue_copy(self.gpu_queue, self.debug_float, self.debug_float_buffer)
+ cl.enqueue_copy(self.gpu_queue, self.debug_integer, self.debug_integer_buffer)
+ print " :: DEBUG :: ", self.debug_float
+ print " :: DEBUG :: ", self.debug_integer
+ self.queued_time += (evt.profile.submit - evt.profile.queued) * 1e-9
+ self.submit_time += (evt.profile.start - evt.profile.submit) * 1e-9
+ self.compute_time[splittingDirection] += (evt.profile.end - evt.profile.start) * 1e-9
+ self.total_flop += nb_ligne * np.prod(l)
+ self.total_bytes_accessed += nb_ligne * np.prod(l) * 4
+ #print "Advection:", self.compute_time * 1e-9
+
+ def __str__(self):
+ """ToString method"""
+ return "VolumeDOp (DiscreteOperator)"
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : VolumeDOp"
+ print VolumeDOp.__doc__
diff --git a/HySoP/unusedOrObsolet/continuous.py b/HySoP/unusedOrObsolet/continuous.py
new file mode 100644
index 0000000000000000000000000000000000000000..9f7b5f11d2eea3097ae62d40f2a2fd464e17f94b
--- /dev/null
+++ b/HySoP/unusedOrObsolet/continuous.py
@@ -0,0 +1,77 @@
+"""
+@package parmepy.problem.continuous
+
+Abstract problem representation.
+"""
+from abc import ABCMeta, abstractmethod
+
+
+class ContinuousProblem:
+ """
+ Abstract description of continuous problem.
+ """
+
+ __metaclass__ = ABCMeta
+
+ @abstractmethod
+ def __init__(self):
+ """
+ Create an empty problem.
+ """
+ print "CONTINUOUS PROBLEM"
+ ## Operators of the problem.
+ self.operators = []
+ ## Discretization of the problem.
+ self.discreteProblem = None
+
+ @abstractmethod
+ def discretize(self, spec=None):
+ """
+ Abstract method.
+ Must be implemented by sub-class.
+
+ @param spec : discretization specifications
+ """
+ raise NotImplementedError("Need to override method in a subclass")
+
+ @abstractmethod
+ def setSolver(self, solver):
+ """
+ Set solver for the discrete problem.
+ It must have a discrete Problem.
+
+ @param solver : solver to use.
+ """
+ if self.discreteProblem == None:
+ raise NotImplementedError("Cannot set solver on a non discretized problem ")
+ self.discreteProblem.setSolver(solver)
+
+ @abstractmethod
+ def setPrinter(self, printer):
+ """
+ Set result printer.
+ It must have a discrete Problem.
+
+ @param printer : printer to use.
+ """
+ if self.discreteProblem == None:
+ raise NotImplementedError("Cannot set printer on a non discretized problem ")
+ self.discreteProblem.setPrinter(printer)
+
+ @abstractmethod
+ def solve(self, T, dt):
+ """
+ Solving the problem.
+ It must have a discrete Problem to solve.
+
+ @param T : Simulation final time
+ @param dt : Simulation time step
+ """
+ if self.discreteProblem == None:
+ raise NotImplementedError("Cannot solve a non discretized problem ")
+ self.discreteProblem.solve(T, dt)
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : ContinuousProblem"
+ print ContinuousProblem.__doc__
diff --git a/HySoP/unusedOrObsolet/cpu_data_transfer-subarray.py b/HySoP/unusedOrObsolet/cpu_data_transfer-subarray.py
new file mode 100644
index 0000000000000000000000000000000000000000..310d8631447db2fb93bf24a9ab04fd8120cdd425
--- /dev/null
+++ b/HySoP/unusedOrObsolet/cpu_data_transfer-subarray.py
@@ -0,0 +1,376 @@
+# -*- coding: utf-8 -*-
+"""
+@file cpu_data_transfer-subarray.py
+Communicator MPI to synchronize ghost
+"""
+
+import numpy as np
+import mpi4py.MPI as MPI
+import time
+
+
+class Synchronize(object):
+ """
+ Synchronization of ghosts values on domain
+ """
+
+ def __init__(self, topology):
+ """
+ Constructor.
+ @param topology : Local topology
+ """
+ self.topo = topology
+ self.total_time = 1
+ ## problem le topology.mesh.resolution peut etre different du shape du field rentre
+ self.size= topology.mesh.resolution
+
+
+ def apply(self, *listFields):
+ """
+ Application of synchronization at a list of Fields
+ @ list of Fields or one Fields.
+ Make the synchronization with this law :
+ for synchronize P1 with P2 :
+ if P1.rank < P2.rank
+ P1 send, own and after recv ghost
+ P2 recv ghost and send his own
+ else
+ do the reciproque
+ And we do that direction by direction, with a sort table of
+ the synchro who need.
+ """
+# Rappel de la correspondance direction <-> indice
+# self.topo.tabSort = np.array([[self.up,0] , [self.down,1] , [self.east,2], [self.west,3],
+# [self.north,4],[self.south,5]])
+ self.compute_time = time.time()
+ self.comm = main_comm
+ self.count = None
+
+ for f in listFields:
+# self.size= f.data[0].shape
+# print 'size array:' ,self.size, 'size topo :', self.topo.mesh.resolution
+# print 'rank', self.topo.rank, 'tab',self.topo.tabSort
+ for i in xrange(self.topo.tabSort[:,0].shape[0]) :
+# print 'rang, destinataire, orientation', self.topo.rank, self.topo.tabSort[i,0], self.topo.tabSort[i,1]
+ if ( self.topo.rank == self.topo.tabSort[i,0]):
+ # UP DOWN
+ if(self.topo.tabSort[i,1] == 0):
+ for j in xrange(self.topo.dim) :
+ f[j][self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:] =\
+ f[j][self.topo.ghosts[0]:2*self.topo.ghosts[0],:,:]
+
+ if(self.topo.tabSort[i,1] == 1):
+ for j in xrange(self.topo.dim) :
+ f[j][0:self.topo.ghosts[0],:,:] =\
+ f[j][self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:]
+
+ # WEST EAST
+ if(self.topo.tabSort[i,1] == 2):
+ for j in xrange(self.topo.dim) :
+ f[j][:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:] =\
+ f[j][:,self.topo.ghosts[1]:2*self.topo.ghosts[1],:]
+
+ if(self.topo.tabSort[i,1] == 3):
+ for j in xrange(self.topo.dim) :
+ f[j][:,0:self.topo.ghosts[1],:] =\
+ f[j][:,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1]:self.topo.mesh.resolution[1]-self.topo.ghosts[1],:]
+
+ # NORTH SOUTH
+ if(self.topo.tabSort[i,1] == 4):
+ for j in xrange(self.topo.dim) :
+ f[j][:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]] =\
+ f[j][:,:,self.topo.ghosts[2]:2*self.topo.ghosts[2]]
+
+ if(self.topo.tabSort[i,1] == 5):
+ for j in xrange(self.topo.dim) :
+ f[j][:,:,0:self.topo.ghosts[2]] =\
+ f[j][:,:,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]:self.topo.mesh.resolution[2]-self.topo.ghosts[2]]
+ else :
+# if(self.topo.tabSort[i,1] == 'up'):
+ if(self.topo.tabSort[i,1] == 0):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'UP',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.UPsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'UP', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.UPrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'down'):
+ if(self.topo.tabSort[i,1] == 1):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'DOWN',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.DOWNsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'DOWN', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.DOWNrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'east'):
+ if(self.topo.tabSort[i,1] == 2):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'EST',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.EASTsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'EST', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.EASTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'west'):
+ if(self.topo.tabSort[i,1] == 3):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'WEST',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.WESTsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'WEST', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.WESTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'north'):
+ if(self.topo.tabSort[i,1] == 4):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'NORTH',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.NORTHsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'NORTH', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.NORTHrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'south'):
+ if(self.topo.tabSort[i,1] == 5):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'SOUTH',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.SOUTHsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'SOUTH', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.SOUTHrecv(self.topo.tabSort[i,0], f)
+ self.compute_time = time.time() - self.compute_time
+ self.total_time += self.compute_time
+
+ return self.compute_time
+
+
+ def UPsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:].shape)
+ startsSend = np.asarray([self.topo.mesh.resolution[0]-2*self.topo.ghosts[0],0,0])
+ UPtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ UPtypeSend.Create_contiguous( UPtypeSend.Get_true_extent()[1] + UPtypeSend.Get_true_extent()[0])
+ UPtypeSend.Commit()
+ self.comm.Send([listFields[i],self.count, UPtypeSend ], dest=proc, tag=11)
+ UPtypeSend.Free()
+ startsRecv = [self.topo.mesh.resolution[0]-self.topo.ghosts[0],0,0]
+ UPtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ UPtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, UPtypeRecv] , source=proc, tag=11)
+ listFields[i][
+ self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]\
+ = data[self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]
+ UPtypeRecv.Free()
+
+
+ def DOWNsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ self.topo.ghosts[0]:2*self.topo.ghosts[0],:,:].shape)
+ startsSend = np.asarray([self.topo.ghosts[0],0,0])
+ DOWNtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ DOWNtypeSend.Commit()
+ self.comm.Send([ listFields[i], DOWNtypeSend ], dest=proc, tag=22)
+ DOWNtypeSend.Free()
+ startsRecv = [0,0,0]
+ DOWNtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ DOWNtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, DOWNtypeRecv], source=proc, tag=22)
+ listFields[i][0:self.topo.ghosts[0],:,:] = data[0:self.topo.ghosts[0],:,:]
+ DOWNtypeRecv.Free()
+
+ def EASTsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1]:self.topo.mesh.resolution[1]-self.topo.ghosts[1],:].shape)
+ startsSend = np.asarray([0,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1],0])
+ EASTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ EASTtypeSend.Commit()
+ self.comm.Send([ listFields[i], EASTtypeSend ], dest=proc, tag=33)
+ EASTtypeSend.Free()
+ startsRecv = [0,self.topo.mesh.resolution[1]-self.topo.ghosts[1],0]
+ EASTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ EASTtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, EASTtypeRecv] , source=proc, tag=33)
+ listFields[i][
+ :,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1] ,:]\
+ = data[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:]
+ EASTtypeRecv.Free()
+
+ def WESTsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,self.topo.ghosts[1]:2*self.topo.ghosts[1],:].shape)
+ startsSend = np.asarray([0,self.topo.ghosts[1],0])
+ WESTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ WESTtypeSend.Commit()
+ self.comm.Send([ listFields[i], WESTtypeSend ], dest=proc, tag=44)
+ WESTtypeSend.Free()
+ startsRecv = [0,0,0]
+ WESTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ WESTtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, WESTtypeRecv], source=proc, tag=44)
+ listFields[i][:,0:self.topo.ghosts[1],:] = data[:,0:self.topo.ghosts[1],:]
+ WESTtypeRecv.Free()
+
+
+ def NORTHsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,:,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]:self.topo.mesh.resolution[2]-self.topo.ghosts[2]].shape)
+ startsSend = np.asarray([0,0,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]])
+ NORTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ NORTHtypeSend.Commit()
+ self.comm.Send([listFields[i], NORTHtypeSend ], dest=proc, tag=55)
+ NORTHtypeSend.Free()
+ startsRecv = [0,0,self.topo.mesh.resolution[2]-self.topo.ghosts[2]]
+ NORTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ NORTHtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, NORTHtypeRecv] , source=proc, tag=55)
+ listFields[i][
+ :,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]\
+ = data[:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]
+ NORTHtypeRecv.Free()
+
+ def SOUTHsend(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,:,self.topo.ghosts[2]:2*self.topo.ghosts[2]].shape)
+ startsSend = np.asarray([0,0,self.topo.ghosts[2]])
+ SOUTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ SOUTHtypeSend.Commit()
+ self.comm.Send([ listFields[i], SOUTHtypeSend ], dest=proc, tag=66)
+ SOUTHtypeSend.Free()
+ startsRecv = [0,0,0]
+ SOUTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ SOUTHtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, SOUTHtypeRecv], source=proc, tag=66)
+ listFields[i][:,:,0:self.topo.ghosts[2]] = data[:,:,0:self.topo.ghosts[2]]
+ SOUTHtypeRecv.Free()
+
+ def UPrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:].shape)
+ startsRecv = np.asarray([self.topo.mesh.resolution[0]-self.topo.ghosts[0],0,0])
+ UPtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ UPtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, UPtypeRecv], source=proc, tag=22)
+ UPtypeRecv.Free()
+ listFields[i][self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:] = data[ \
+ self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]
+ startsSend = [self.topo.mesh.resolution[0]-2*self.topo.ghosts[0],0,0]
+ UPtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ UPtypeSend.Commit()
+ self.comm.Send([listFields[i], UPtypeSend], dest=proc, tag=22)
+ UPtypeSend.Free()
+
+
+ def DOWNrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ 0:self.topo.ghosts[0],:,:].shape)
+ startsRecv = np.asarray([0,0,0])
+ data=listFields[i]
+ DOWNtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ DOWNtypeRecv.Create_contiguous( DOWNtypeRecv.Get_true_extent()[1] + DOWNtypeRecv.Get_true_extent()[0])
+ DOWNtypeRecv.Commit()
+ self.comm.Recv([data, self.count , DOWNtypeRecv], source = proc, tag =11)
+ DOWNtypeRecv.Free()
+ listFields[i][0:self.topo.ghosts[0],:,:] = data[0:self.topo.ghosts[0],:,:]
+ startsSend = [self.topo.ghosts[0],0,0]
+ DOWNtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ DOWNtypeSend.Commit()
+ self.comm.Send([listFields[i], DOWNtypeSend], dest = proc, tag =11)
+ DOWNtypeSend.Free()
+
+
+ def EASTrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:].shape)
+ startsRecv = np.asarray([0,self.topo.mesh.resolution[1]-self.topo.ghosts[1],0])
+ EASTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ EASTtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, EASTtypeRecv], source=proc, tag=44)
+ EASTtypeRecv.Free()
+ listFields[i][:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:] = data[ \
+ :,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:]
+ startsSend = [0,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1],0]
+ EASTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ EASTtypeSend.Commit()
+ self.comm.Send([listFields[i], EASTtypeSend], dest=proc, tag=44)
+ EASTtypeSend.Free()
+
+ def WESTrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,0:self.topo.ghosts[1],:].shape)
+ startsRecv = np.asarray([0,0,0])
+ WESTtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ WESTtypeRecv.Commit()
+ data=listFields[i]
+ self.comm.Recv([data, WESTtypeRecv], source = proc, tag =33)
+ WESTtypeRecv.Free()
+ listFields[i][:,0:self.topo.ghosts[1],:] = data[:,0:self.topo.ghosts[1],:]
+ startsSend = [0,self.topo.ghosts[1],0]
+ WESTtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ WESTtypeSend.Commit()
+ self.comm.Send([listFields[i], WESTtypeSend], dest = proc, tag =33)
+ WESTtypeSend.Free()
+
+ def NORTHrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]].shape)
+ startsRecv = np.asarray([0,0,self.topo.mesh.resolution[2]-self.topo.ghosts[2]])
+ NORTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ NORTHtypeRecv.Commit()
+ data = listFields[i]
+ self.comm.Recv([data, NORTHtypeRecv], source=proc, tag=66)
+ NORTHtypeRecv.Free()
+ listFields[i][:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]] = data[ \
+ :,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]
+ startsSend = [0,0,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]]
+ NORTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ NORTHtypeSend.Commit()
+ self.comm.Send([listFields[i], NORTHtypeSend], dest=proc, tag=66)
+ NORTHtypeSend.Free()
+
+ def SOUTHrecv(self, proc, listFields):
+ for i in xrange(self.topo.dim) :
+ subsizes = np.asarray(listFields[i][ \
+ :,:,0:self.topo.ghosts[2]].shape)
+ startsRecv = np.asarray([0,0,0])
+ SOUTHtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=ORDERMPI)
+ SOUTHtypeRecv.Commit()
+ data=listFields[i]
+ self.comm.Recv([data, SOUTHtypeRecv], source = proc, tag =55)
+ SOUTHtypeRecv.Free()
+ listFields[i][:,:,0:self.topo.ghosts[2]] = data[:,:,0:self.topo.ghosts[2]]
+ startsSend = [0,0,self.topo.ghosts[2]]
+ SOUTHtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=ORDERMPI)
+ SOUTHtypeSend.Commit()
+ self.comm.Send([listFields[i], SOUTHtypeSend], dest = proc, tag =55)
+ SOUTHtypeSend.Free()
+
+
+ def printComputeTime(self):
+ self.timings_info[0] = "\"Synchronization total\""
+ self.timings_info[1] = str(self.total_time)
+ print "Synchronization total time : ", self.total_time
+ print "Time of the last Synchronization iteration :", self.compute_time
+
+ def __str__(self):
+ s = "Synchronize. "
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : Synchronize"
+ print Synchronize.__doc__
diff --git a/HySoP/unusedOrObsolet/cpu_data_transfer.py b/HySoP/unusedOrObsolet/cpu_data_transfer.py
new file mode 100644
index 0000000000000000000000000000000000000000..576ae0ab78ea01a646a658590945bbae38b4be27
--- /dev/null
+++ b/HySoP/unusedOrObsolet/cpu_data_transfer.py
@@ -0,0 +1,301 @@
+# -*- coding: utf-8 -*-
+"""
+@file cpu_data_transfer.py
+Communicator MPI to synchronize ghost
+"""
+from parmepy.constants import np, ORDER
+from parmepy.mpi import main_comm
+import time
+
+
+class Synchronize(object):
+ """
+ Synchronization of ghosts values on domain
+ """
+
+ def __init__(self, topology):
+ """
+ Constructor.
+ @param topology : Local topology
+ """
+ self.topo = topology
+ self.total_time = 1
+ ## problem le topology.mesh.resolution peut etre different du shape du field rentre
+ self.size= topology.mesh.resolution
+
+ def apply(self, *listFields):
+ """
+ Application of synchronization at a list of Fields
+ @ list of Fields or one Fields.
+ Make the synchronization with this law :
+ for synchronize P1 with P2 :
+ if P1.rank < P2.rank
+ P1 send, own and after recv ghost
+ P2 recv ghost and send his own
+ else
+ do the reciproque
+ And we do that direction by direction, with a sort table of
+ the synchro who need.
+ """
+# Rappel de la correspondance direction <-> indice
+# self.topo.tabSort = np.array([[self.up,0] , [self.down,1] , [self.east,2], [self.west,3],
+# [self.north,4],[self.south,5]])
+ self.compute_time = time.time()
+ self.comm = main_comm
+ self.count = None
+
+ for f in listFields:
+# self.size= f.data[0].shape
+# print 'size array:' ,self.size, 'size topo :', self.topo.mesh.resolution
+# print 'rank', self.topo.rank, 'tab',self.topo.tabSort
+ for i in xrange(self.topo.tabSort[:,0].shape[0]) :
+# print 'rang, destinataire, orientation', self.topo.rank, self.topo.tabSort[i,0], self.topo.tabSort[i,1]
+ if ( self.topo.rank == self.topo.tabSort[i,0]):
+ # UP DOWN
+ if(self.topo.tabSort[i,1] == 0):
+ for j in xrange(self.topo.dim) :
+ f[j][self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:] =\
+ f[j][self.topo.ghosts[0]:2*self.topo.ghosts[0],:,:]
+
+ if(self.topo.tabSort[i,1] == 1):
+ for j in xrange(self.topo.dim) :
+ f[j][0:self.topo.ghosts[0],:,:] =\
+ f[j][self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:]
+
+ # WEST EAST
+ if(self.topo.tabSort[i,1] == 2):
+ for j in xrange(self.topo.dim) :
+ f[j][:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:] =\
+ f[j][:,self.topo.ghosts[1]:2*self.topo.ghosts[1],:]
+
+ if(self.topo.tabSort[i,1] == 3):
+ for j in xrange(self.topo.dim) :
+ f[j][:,0:self.topo.ghosts[1],:] =\
+ f[j][:,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1]:self.topo.mesh.resolution[1]-self.topo.ghosts[1],:]
+
+ # NORTH SOUTH
+ if(self.topo.tabSort[i,1] == 4):
+ for j in xrange(self.topo.dim) :
+ f[j][:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]] =\
+ f[j][:,:,self.topo.ghosts[2]:2*self.topo.ghosts[2]]
+
+ if(self.topo.tabSort[i,1] == 5):
+ for j in xrange(self.topo.dim) :
+ f[j][:,:,0:self.topo.ghosts[2]] =\
+ f[j][:,:,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]:self.topo.mesh.resolution[2]-self.topo.ghosts[2]]
+ else :
+# if(self.topo.tabSort[i,1] == 'up'):
+ if(self.topo.tabSort[i,1] == 0):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'UP',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.UPsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'UP', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.UPrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'down'):
+ if(self.topo.tabSort[i,1] == 1):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'DOWN',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.DOWNsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'DOWN', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.DOWNrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'east'):
+ if(self.topo.tabSort[i,1] == 2):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'EST',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.EASTsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'EST', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.EASTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'west'):
+ if(self.topo.tabSort[i,1] == 3):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'WEST',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.WESTsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'WEST', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.WESTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'north'):
+ if(self.topo.tabSort[i,1] == 4):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'NORTH',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.NORTHsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'NORTH', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.NORTHrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'south'):
+ if(self.topo.tabSort[i,1] == 5):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+# print 'SOUTH',self.topo.rank,'Send to',self.topo.tabSort[i,0]
+ self.SOUTHsend(self.topo.tabSort[i,0], f)
+ else :
+# print 'SOUTH', self.topo.rank,'Recv from',self.topo.tabSort[i,0]
+ self.SOUTHrecv(self.topo.tabSort[i,0], f)
+ self.compute_time = time.time() - self.compute_time
+ self.total_time += self.compute_time
+
+ return self.compute_time
+
+
+ def UPsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((ghosts[0],resolution[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=11)
+ self.comm.Recv(data , source=proc, tag=11)
+ listFields[i][
+ self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]\
+ = data
+
+
+ def DOWNsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((ghosts[0],resolution[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ ghosts[0]:2*ghosts[0],:,:]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=22)
+ self.comm.Recv(data , source=proc, tag=22)
+ listFields[i][0:ghosts[0],:,:] = data
+
+
+ def EASTsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], ghosts[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ :,resolution[1]-2*ghosts[1]:resolution[1]-ghosts[1],:]), order=ORDER)
+
+ self.comm.Ssend(data, dest=proc, tag=33)
+ self.comm.Recv(data , source=proc, tag=33)
+ listFields[i][:,resolution[1]-ghosts[1]:resolution[1],:]= data
+
+
+ def WESTsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], ghosts[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ :,ghosts[1]:ghosts[1]*2,:]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=44)
+ self.comm.Recv(data , source=proc, tag=44)
+ listFields[i][:,0:ghosts[1],:]= data
+
+
+ def NORTHsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], resolution[1], ghosts[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ :,:,resolution[2]-2*ghosts[2]:resolution[2]-ghosts[2]]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=55)
+ self.comm.Recv(data , source=proc, tag=55)
+ listFields[i][:,:,resolution[2]-ghosts[2]:resolution[2]]= data
+
+
+ def SOUTHsend(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], resolution[1], ghosts[2]) , dtype=PARMES_REAL , order=ORDER)
+ data = np.array(np.copy(listFields[i][ \
+ :,:,ghosts[2]:2*ghosts[2]]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=66)
+ self.comm.Recv(data , source=proc, tag=66)
+ listFields[i][:,:,0:ghosts[2]]= data
+
+
+ def UPrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((ghosts[0],resolution[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data, source = proc, tag =22)
+ listFields[i][resolution[0]-ghosts[0]:resolution[0],:,:] = data
+ data = np.array(np.copy(listFields[i][ \
+ resolution[0]-2*ghosts[0]:resolution[0]-ghosts[0],:,:]), order=ORDER)
+ self.comm.Ssend(data, dest = proc, tag =22)
+
+
+ def DOWNrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((ghosts[0],resolution[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data, source = proc, tag =11)
+ listFields[i][0:self.topo.ghosts[0],:,:] = data
+ data = np.array(np.copy(listFields[i][ \
+ ghosts[0]:ghosts[0]*2,:,:]), order=ORDER)
+ self.comm.Ssend(data, dest = proc, tag =11)
+
+
+ def EASTrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], ghosts[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data , source=proc, tag=44)
+ listFields[i][:,resolution[1]-ghosts[1]:resolution[1],:]= data
+ data = np.array(np.copy(listFields[i][ \
+ :,resolution[1]-2*ghosts[1]:resolution[1]-ghosts[1],:]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=44)
+
+
+ def WESTrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], ghosts[1], resolution[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data , source=proc, tag=33)
+ listFields[i][:,0:ghosts[1],:]= data
+ data = np.array(np.copy(listFields[i][ \
+ :,ghosts[1]:2*ghosts[1],:]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=33)
+
+
+ def NORTHrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], resolution[1], ghosts[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data , source=proc, tag=66)
+ listFields[i][:,:,resolution[2]-ghosts[2]:resolution[2]]= data
+ data = np.array(np.copy(listFields[i][ \
+ :,:,resolution[2]-2*ghosts[2]:resolution[2]-ghosts[2]]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=66)
+
+
+ def SOUTHrecv(self, proc, listFields):
+ ghosts= self.topo.ghosts
+ resolution = self.topo.mesh.resolution
+ for i in xrange(self.topo.dim) :
+ data = np.zeros((resolution[0], resolution[1], ghosts[2]) , dtype=PARMES_REAL , order=ORDER)
+ self.comm.Recv(data , source=proc, tag=55)
+ listFields[i][:,:,0:ghosts[2]]= data
+ data = np.array(np.copy(listFields[i][ \
+ :,:,ghosts[2]:2*ghosts[2]]), order=ORDER)
+ self.comm.Ssend(data, dest=proc, tag=55)
+
+
+ def printComputeTime(self):
+ self.timings_info[0] = "\"Synchronization total\""
+ self.timings_info[1] = str(self.total_time)
+ print "Synchronization total time : ", self.total_time
+ print "Time of the last Synchronization iteration :", self.compute_time
+
+ def __str__(self):
+ s = "Synchronize. "
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : Synchronize"
+ print Synchronize.__doc__
diff --git a/HySoP/unusedOrObsolet/cpu_data_transfer_S.py b/HySoP/unusedOrObsolet/cpu_data_transfer_S.py
new file mode 100644
index 0000000000000000000000000000000000000000..90b908a45a335c3dd5929b732674fc93586ca9c5
--- /dev/null
+++ b/HySoP/unusedOrObsolet/cpu_data_transfer_S.py
@@ -0,0 +1,307 @@
+# -*- coding: utf-8 -*-
+"""
+@file cpu_data_transfer_S.py
+Communicator MPI to synchronize ghosts of scalar fields
+"""
+from parmepy.constants import np, ORDER
+from parmepy.mpi import main_comm
+import time
+
+
+class SynchronizeS(object):
+ """
+ Synchronization of ghosts values for scalar fields
+ """
+
+ def __init__(self, topology):
+ """
+ Constructor.
+ @param topology : Local topology
+ """
+ self.topo = topology
+ self.total_time = 0.
+ self.size= topology.mesh.resolution
+
+
+ def apply(self, *listFields):
+ """
+ Application of data synchronization to a list of scalar Fields
+ @ list of scalar Fields
+ Make the synchronization with this law :
+ to synchronize P1 with P2 :
+ if P1.rank < P2.rank
+ P1 send its own and after recv ghost
+ P2 recv ghost and send its own
+ else
+ do the reciproque
+ This algorithm is performed orientation by orientation,
+ using a sorted table containing neighbours ranks and their orientation as follows :
+ """
+# Rappel de la correspondance direction <-> indice
+# self.topo.tabSort = np.array([[self.up,0] , [self.down,1] , [self.east,2], [self.west,3],
+# [self.north,4],[self.south,5]])
+ self.compute_time = time.time()
+ self.comm = main_comm
+
+ for f in listFields:
+ for i in xrange(self.topo.tabSort[:,0].shape[0]) :
+ if ( self.topo.rank == self.topo.tabSort[i,0]):
+ # UP DOWN
+ if(self.topo.tabSort[i,1] == 0):
+ f[self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:] =\
+ f[self.topo.ghosts[0]:2*self.topo.ghosts[0],:,:]
+
+ if(self.topo.tabSort[i,1] == 1):
+ f[0:self.topo.ghosts[0],:,:] =\
+ f[self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:]
+
+ # WEST EAST
+ if(self.topo.tabSort[i,1] == 2):
+ f[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:] =\
+ f[:,self.topo.ghosts[1]:2*self.topo.ghosts[1],:]
+
+ if(self.topo.tabSort[i,1] == 3):
+ f[:,0:self.topo.ghosts[1],:] =\
+ f[:,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1]:self.topo.mesh.resolution[1]-self.topo.ghosts[1],:]
+
+ # NORTH SOUTH
+ if(self.topo.tabSort[i,1] == 4):
+ f[:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]] =\
+ f[:,:,self.topo.ghosts[2]:2*self.topo.ghosts[2]]
+
+ if(self.topo.tabSort[i,1] == 5):
+ f[:,:,0:self.topo.ghosts[2]] =\
+ f[:,:,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]:self.topo.mesh.resolution[2]-self.topo.ghosts[2]]
+ else :
+# if(self.topo.tabSort[i,1] == 'up'):
+ if(self.topo.tabSort[i,1] == 0):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.UPsend(self.topo.tabSort[i,0], f)
+ else :
+ self.UPrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'down'):
+ if(self.topo.tabSort[i,1] == 1):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.DOWNsend(self.topo.tabSort[i,0], f)
+ else :
+ self.DOWNrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'east'):
+ if(self.topo.tabSort[i,1] == 2):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.EASTsend(self.topo.tabSort[i,0], f)
+ else :
+ self.EASTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'west'):
+ if(self.topo.tabSort[i,1] == 3):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.WESTsend(self.topo.tabSort[i,0], f)
+ else :
+ self.WESTrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'north'):
+ if(self.topo.tabSort[i,1] == 4):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.NORTHsend(self.topo.tabSort[i,0], f)
+ else :
+ self.NORTHrecv(self.topo.tabSort[i,0], f)
+# if(self.topo.tabSort[i,1] == 'south'):
+ if(self.topo.tabSort[i,1] == 5):
+ if( self.topo.rank < self.topo.tabSort[i,0]) :
+ self.SOUTHsend(self.topo.tabSort[i,0], f)
+ else :
+ self.SOUTHrecv(self.topo.tabSort[i,0], f)
+ self.compute_time = time.time() - self.compute_time
+ self.total_time += self.compute_time
+
+ return self.compute_time
+
+
+ def UPsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ self.topo.mesh.resolution[0]-2*self.topo.ghosts[0]:self.topo.mesh.resolution[0]-self.topo.ghosts[0],:,:].shape)
+ startsSend = np.asarray([self.topo.mesh.resolution[0]-2*self.topo.ghosts[0],0,0])
+ UPtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ UPtypeSend.Commit()
+ self.comm.Send([ listFields, UPtypeSend ], dest=proc, tag=77)
+ startsRecv = [self.topo.mesh.resolution[0]-self.topo.ghosts[0],0,0]
+ UPtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ UPtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, UPtypeRecv] , source=proc, tag=77)
+ listFields[self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]\
+ = data[self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:]
+
+ def DOWNsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ self.topo.ghosts[0]:2*self.topo.ghosts[0],:,:].shape)
+ startsSend = np.asarray([self.topo.ghosts[0],0,0])
+ DOWNtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ DOWNtypeSend.Commit()
+ self.comm.Send([ listFields, DOWNtypeSend ], dest=proc, tag=77)
+ startsRecv = [0,0,0]
+ DOWNtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ DOWNtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, DOWNtypeRecv], source=proc, tag=77)
+ listFields[0:self.topo.ghosts[0],:,:] = data[0:self.topo.ghosts[0],:,:]
+
+ def EASTsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1]:self.topo.mesh.resolution[1]-self.topo.ghosts[1],:].shape)
+ startsSend = np.asarray([0,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1],0])
+ EASTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ EASTtypeSend.Commit()
+ self.comm.Send([ listFields, EASTtypeSend ], dest=proc, tag=33)
+ startsRecv = [0,self.topo.mesh.resolution[1]-self.topo.ghosts[1],0]
+ EASTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ EASTtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, EASTtypeRecv] , source=proc, tag=33)
+ listFields[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1] ,:]\
+ = data[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:]
+
+ def WESTsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,self.topo.ghosts[1]:2*self.topo.ghosts[1],:].shape)
+ startsSend = np.asarray([0,self.topo.ghosts[1],0])
+ WESTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ WESTtypeSend.Commit()
+ self.comm.Send([ listFields, WESTtypeSend ], dest=proc, tag=33)
+ startsRecv = [0,0,0]
+ WESTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ WESTtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, WESTtypeRecv], source=proc, tag=33)
+ listFields[:,0:self.topo.ghosts[1],:] = data[:,0:self.topo.ghosts[1],:]
+
+ def NORTHsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,:,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]:self.topo.mesh.resolution[2]-self.topo.ghosts[2]].shape)
+ startsSend = np.asarray([0,0,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]])
+ NORTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ NORTHtypeSend.Commit()
+ self.comm.Send([ listFields, NORTHtypeSend ], dest=proc, tag=55)
+ startsRecv = [0,0,self.topo.mesh.resolution[2]-self.topo.ghosts[2]]
+ NORTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ NORTHtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, NORTHtypeRecv] , source=proc, tag=55)
+ listFields[:,:, self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]\
+ = data[:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]
+
+ def SOUTHsend(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,:,self.topo.ghosts[2]:2*self.topo.ghosts[2]].shape)
+ startsSend = np.asarray([0,0,self.topo.ghosts[2]])
+ SOUTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ SOUTHtypeSend.Commit()
+ self.comm.Send([ listFields, SOUTHtypeSend ], dest=proc, tag=55)
+ startsRecv = [0,0,0]
+ SOUTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ SOUTHtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, SOUTHtypeRecv], source=proc, tag=55)
+ listFields[:,:,0:self.topo.ghosts[2]] = data[:,:,0:self.topo.ghosts[2]]
+
+ def UPrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ self.topo.mesh.resolution[0]-self.topo.ghosts[0]:self.topo.mesh.resolution[0],:,:].shape)
+ startsRecv = np.asarray([self.topo.mesh.resolution[0]-self.topo.ghosts[0],0,0])
+ UPtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ UPtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, UPtypeRecv], source=proc, tag=77)
+ listFields[self.topo.mesh.resolution[0] -
+ self.topo.ghosts[0]:self.topo.mesh.resolution[0], :, :] = \
+ data[self.topo.mesh.resolution[0] -
+ self.topo.ghosts[0]:self.topo.mesh.resolution[0], :, :]
+ startsSend = [self.topo.mesh.resolution[0] -
+ 2 * self.topo.ghosts[0], 0, 0]
+ UPtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ UPtypeSend.Commit()
+ self.comm.Send([listFields, UPtypeSend], dest=proc, tag=77)
+
+
+ def DOWNrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[0:self.topo.ghosts[0],:,:].shape)
+ startsRecv = np.asarray([0,0,0])
+ DOWNtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ DOWNtypeRecv.Commit()
+ data=listFields
+ self.comm.Recv([data, DOWNtypeRecv], source = proc, tag =77)
+ listFields[0:self.topo.ghosts[0],:,:] = data[0:self.topo.ghosts[0],:,:]
+ startsSend = [self.topo.ghosts[0],0,0]
+ DOWNtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ DOWNtypeSend.Commit()
+ self.comm.Send([listFields, DOWNtypeSend], dest = proc, tag =77)
+
+ def EASTrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:].shape)
+ startsRecv = np.asarray([0,self.topo.mesh.resolution[1]-self.topo.ghosts[1],0])
+ EASTtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ EASTtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, EASTtypeRecv], source=proc, tag=33)
+ listFields[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:] = \
+ data[:,self.topo.mesh.resolution[1]-self.topo.ghosts[1]:self.topo.mesh.resolution[1],:]
+ startsSend = [0,self.topo.mesh.resolution[1]-2*self.topo.ghosts[1],0]
+ EASTtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ EASTtypeSend.Commit()
+ self.comm.Send([listFields, EASTtypeSend], dest=proc, tag=33)
+
+ def WESTrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,0:self.topo.ghosts[1],:].shape)
+ startsRecv = np.asarray([0,0,0])
+ WESTtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ WESTtypeRecv.Commit()
+ data=listFields
+ self.comm.Recv([data, WESTtypeRecv], source = proc, tag =33)
+ listFields[:,0:self.topo.ghosts[1],:] = data[:,0:self.topo.ghosts[1],:]
+ startsSend = [0,self.topo.ghosts[1],0]
+ WESTtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ WESTtypeSend.Commit()
+ self.comm.Send([listFields, WESTtypeSend], dest = proc, tag =33)
+
+ def NORTHrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[ \
+ :,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]].shape)
+ startsRecv = np.asarray([0,0,self.topo.mesh.resolution[2]-self.topo.ghosts[2]])
+ NORTHtypeRecv = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ NORTHtypeRecv.Commit()
+ data = listFields
+ self.comm.Recv([data, NORTHtypeRecv], source=proc, tag=55)
+ listFields[:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]] = \
+ data[:,:,self.topo.mesh.resolution[2]-self.topo.ghosts[2]:self.topo.mesh.resolution[2]]
+ startsSend = [0,0,self.topo.mesh.resolution[2]-2*self.topo.ghosts[2]]
+ NORTHtypeSend = MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ NORTHtypeSend.Commit()
+ self.comm.Send([listFields, NORTHtypeSend], dest=proc, tag=55)
+
+ def SOUTHrecv(self, proc, listFields):
+ subsizes = np.asarray(listFields[:,:,0:self.topo.ghosts[2]].shape)
+ startsRecv = np.asarray([0,0,0])
+ SOUTHtypeRecv= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsRecv, order=MPI.ORDER_F)
+ SOUTHtypeRecv.Commit()
+ data=listFields
+ self.comm.Recv([data, SOUTHtypeRecv], source = proc, tag =55)
+ listFields[:,:,0:self.topo.ghosts[2]] = data[:,:,0:self.topo.ghosts[2]]
+ startsSend = [0,0,self.topo.ghosts[2]]
+ SOUTHtypeSend= MPI.DOUBLE.Create_subarray(self.size, subsizes, startsSend, order=MPI.ORDER_F)
+ SOUTHtypeSend.Commit()
+ self.comm.Send([listFields, SOUTHtypeSend], dest = proc, tag =55)
+
+ def printComputeTime(self):
+ self.timings_info[0] = "\"Synchronization total\""
+ self.timings_info[1] = str(self.total_time)
+ print "Synchronization total time : ", self.total_time
+ print "Time of the last Synchronization iteration :", self.compute_time
+
+ def __str__(self):
+ s = "Synchronize. "
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : Synchronize scalar fields"
+ print SynchronizeS.__doc__
diff --git a/HySoP/unusedOrObsolet/differentialOperator.py b/HySoP/unusedOrObsolet/differentialOperator.py
new file mode 100755
index 0000000000000000000000000000000000000000..7e377277eff801ff7e757265342eeb24d21e31d6
--- /dev/null
+++ b/HySoP/unusedOrObsolet/differentialOperator.py
@@ -0,0 +1,683 @@
+# -*- codingind utf-8 -*-
+"""
+@file differentialOperator.py
+Discrete stretching representation
+"""
+import numpy as np
+from parmepy.constants import np, PARMES_REAL, ORDER
+from parmepy.numerics.method import NumMethod
+#from parmepy.tools.cpu_data_transfer import Synchronize
+from parmepy.tools.cpu_data_transfer_S import SynchronizeS
+
+
+class DifferentialOperator(NumMethod):
+ """
+ Operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, field1, field2, method='', choice=''):
+ """
+ Constructor.
+ Create a Stretching operator on a given continuous domain.
+ Work on a given field2 and field1 to compute the stretching term.
+
+ @param field1 : field n1 (vorticity).
+ @param field2 : field n2 (velocity or density).
+ @param method : name and order of the spacial discretization method.
+ @param choice : differential operator to discretize
+ """
+ self.name = "Differential Operator Discretization"
+ self.field1 = field1
+ self.field2 = field2
+ self.choice = choice
+ self.method = method
+ self.compute_time = 0.
+ self.topology = self.field2.topology
+ self.meshSize = self.topology.mesh.space_step
+
+# def setUp(self):
+# pass
+
+ def __call__(self, synchroOp=None):
+ """
+ Apply operator.
+ """
+ ind0a = self.topology.mesh.local_start[0]
+ ind0b = self.topology.mesh.local_end[0] + 1
+ ind1a = self.topology.mesh.local_start[1]
+ ind1b = self.topology.mesh.local_end[1] + 1
+ ind2a = self.topology.mesh.local_start[2]
+ ind2b = self.topology.mesh.local_end[2] + 1
+ ind0 = np.arange(ind0a, ind0b)
+ ind1 = np.arange(ind1a, ind1b)
+ ind2 = np.arange(ind2a, ind2b)
+ if self.choice.find('divWU') >= 0:
+
+ # Ghosts synchronization
+# linenb = 0
+# if (self.topology.rank == 0):
+# time.sleep(2)
+# print 'Bligne 1', field1[:,linenb,linenb]
+# time.sleep(2)
+# print 'Bligne 2', field1[linenb,:,linenb]
+# time.sleep(2)
+# print 'Bligne 3', field1[linenb,linenb,:]
+# time.sleep(2)
+
+# if (self.topology.rank == 0):
+# time.sleep(2)
+# print 'Aligne 1', field1[:,linenb,linenb]
+# time.sleep(2)
+# print 'Aligne 2', field1[linenb,:,linenb]
+# time.sleep(2)
+# print 'Aligne 3', field1[linenb,linenb,:]
+# time.sleep(2)
+ OpSynchronize = Synchronize(self.topology)
+ OpSynchronize.apply(self.field2, self.field1)
+
+ synchroOp.apply()
+ if self.method.find('FD_order2') >= 0:
+ raise ValueError("2nd order scheme Not yet implemented")
+## X components of temp and result
+# temp1 = (
+# self.field1[0][ind+1, ind, ind] *
+# self.field2[0][ind+1, ind, ind] -
+# self.field1[0][ind-1, ind, ind] *
+# self.field2[0][ind-1, ind, ind]
+# ) / (2. * self.meshSize[0])
+
+# temp2 = (
+# self.field1[1][ind, ind+1, ind] *
+# self.field2[0][ind, ind+1, ind] -
+# self.field1[1][ind, ind-1, ind] *
+# self.field2[0][ind, ind-1, ind]
+# ) / (2. * self.meshSize[1])
+#
+# temp3 = (
+# self.field1[2][ind, ind, ind+1] *
+# self.field2[0][ind, ind, ind+1] -
+# self.field1[2][ind, ind, ind-1] *
+# self.field2[0][ind, ind, ind-1]
+# ) / (2. * self.meshSize[2])
+
+# self.result[0][ind, ind]= temp1 + temp2 + temp3
+
+## Y components of temp and result
+# temp1 = (
+# self.field1[0][ind+1, ind, ind] *
+# self.field2[1][ind+1, ind, ind] -
+# self.field1[0][ind-1, ind, ind] *
+# self.field2[1][ind-1, ind, ind]
+# ) / (2. * self.meshSize[0])
+
+# temp2 = (
+# self.field1[1][ind, ind+1, ind] *
+# self.field2[1][ind, ind+1, ind] -
+# self.field1[1][ind, ind-1, ind] *
+# self.field2[1][ind, ind-1, ind]
+# ) / (2. * self.meshSize[1])
+#
+# temp3 = (
+# self.field1[2][ind, ind, ind+1] *
+# self.field2[1][ind, ind, ind+1] -
+# self.field1[2][ind, ind, ind-1] *
+# self.field2[1][ind, ind, ind-1]
+# ) / (2. * self.meshSize[2])
+
+# self.result[1][ind, ind]= temp1 + temp2 + temp3
+
+## Z components of temp and result
+# temp1 = (
+# self.field1[0][ind+1, ind, ind] *
+# self.field2[2][ind+1, ind, ind] -
+# self.field1[0][ind-1, ind, ind] *
+# self.field2[2][ind-1, ind, ind]
+# ) / (2. * self.meshSize[0])
+
+# temp2 = (
+# self.field1[1][ind, ind+1, ind] *
+# self.field2[2][ind, ind+1, ind] -
+# self.field1[1][ind, ind-1, ind] *
+# self.field2[2][ind, ind-1, ind]
+# ) / (2. * self.meshSize[1])
+#
+# temp3 = (
+# self.field1[2][ind, ind, ind+1] *
+# self.field2[2][ind, ind, ind+1] -
+# self.field1[2][ind, ind, ind-1] *
+# self.field2[2][ind, ind, ind-1]
+# ) / (2. * self.meshSize[2])
+
+ else:
+# X components of temp and result
+ temp1 = self.field2[0][...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[0][ind0-2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[0][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[0][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field1[0][ind0+1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[0][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field1[0][ind0+2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[0][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+ temp2 = self.field2[0][...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[1][ind0a:ind0b, ind1-2, ind2a:ind2b] *
+ self.field2[0][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field1[1][ind0a:ind0b, ind1-1, ind2a:ind2b] *
+ self.field2[0][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field1[1][ind0a:ind0b, ind1+1, ind2a:ind2b] *
+ self.field2[0][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field1[1][ind0a:ind0b, ind1+2, ind2a:ind2b] *
+ self.field2[0][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+ temp3 = self.field2[0][...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-2] *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-1] *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+1] *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+2] *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+# tmp1 = np.array([temp1 + temp2 + temp3])
+ tmp1 = temp1 + temp2 + temp3
+
+# Y components of temp and result
+ temp1 = self.field2[1][...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[0][ind0-2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[1][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[1][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field1[0][ind0+1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[1][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field1[0][ind0+2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[1][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+ temp2 = self.field2[1][...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[1][ind0a:ind0b, ind1-2, ind2a:ind2b] *
+ self.field2[1][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field1[1][ind0a:ind0b, ind1-1, ind2a:ind2b] *
+ self.field2[1][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field1[1][ind0a:ind0b, ind1+1, ind2a:ind2b] *
+ self.field2[1][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field1[1][ind0a:ind0b, ind1+2, ind2a:ind2b] *
+ self.field2[1][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+ temp3 = self.field2[1][...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-2] *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-1] *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+1] *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+2] *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+# tmp2 = np.array([temp1 + temp2 + temp3])
+ tmp2 = temp1 + temp2 + temp3
+
+# Z components of temp and result
+ temp1 = self.field2[2][...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[0][ind0-2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[2][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[2][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field1[0][ind0+1, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[2][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field1[0][ind0+2, ind1a:ind1b, ind2a:ind2b] *
+ self.field2[2][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+ temp2 = self.field2[2][...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[1][ind0a:ind0b, ind1-2, ind2a:ind2b] *
+ self.field2[2][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field1[1][ind0a:ind0b, ind1-1, ind2a:ind2b] *
+ self.field2[2][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field1[1][ind0a:ind0b, ind1+1, ind2a:ind2b] *
+ self.field2[2][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field1[1][ind0a:ind0b, ind1+2, ind2a:ind2b] *
+ self.field2[2][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+ temp3 = self.field2[2][...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-2] *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2-1] *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+1] *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field1[2][ind0a:ind0b, ind1a:ind1b, ind2+2] *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+# tmp3 = np.array([temp1 + temp2 + temp3])
+ tmp3 = temp1 + temp2 + temp3
+ result = np.concatenate((
+ np.array(tmp1), np.array(tmp2), np.array(tmp3)))
+# return result
+ return tmp1, tmp2, tmp3
+
+ elif self.choice.find('gradV') >= 0:
+
+ # Ghosts synchronization
+ synchroOp.apply()
+# OpSynchronize = Synchronize(self.topology)
+# OpSynchronize.apply(self.field2)
+ if self.method.find('FD_order2') >= 0:
+ raise ValueError("2nd order scheme Not yet implemented")
+
+ else:
+ maxArray = np.zeros(5, dtype=PARMES_REAL, order=ORDER)
+
+## Fourth order scheme
+# X components of temp and result
+# temp1 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp1 = self.field2[0][...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[0][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field2[0][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field2[0][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field2[0][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+# temp2 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp2 = self.field2[0][...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[0][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field2[0][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field2[0][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field2[0][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+# temp3 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp3 = self.field2[0][...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+ maxstr1 = np.max(abs(temp1) + abs(temp2) + abs(temp3))
+ maxadv1 = np.max(abs(temp1))
+
+# Y components of temp and result
+# temp4 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp4 = self.field2[1][...] * 0.
+ temp4[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[1][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field2[1][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field2[1][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field2[1][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+# temp5 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp5 = self.field2[1][...] * 0.
+ temp5[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[1][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field2[1][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field2[1][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field2[1][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+# temp6 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp6 = self.field2[1][...] * 0.
+ temp6[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+ maxstr2 = np.max(abs(temp4)+abs(temp5)+abs(temp6))
+ maxadv2 = np.max(abs(temp5))
+
+# Z components of temp and result
+# temp7 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp7 = self.field2[2][...] * 0.
+ temp7[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[2][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field2[2][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field2[2][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field2[2][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+# temp8 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp8 = self.field2[2][...] * 0.
+ temp8[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[2][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field2[2][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field2[2][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field2[2][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+# temp9 = np.zeros(
+# (self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp9 = self.field2[2][...] * 0.
+ temp9[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+ maxstr3 = np.max(abs(temp7)+abs(temp8)+abs(temp9))
+ maxadv3 = np.max(abs(temp9))
+
+ # grad(V) result
+ result = np.concatenate((
+ np.array([temp1, temp2, temp3]),
+ np.array([temp4, temp5, temp6]),
+ np.array([temp7, temp8, temp9])
+ ))
+ # div(V) result
+ divergence = np.array(temp1 + temp5 + temp9)
+
+ # maxima of partial derivatives : needed for stab conditions
+ # advection stab
+ maxArray[0] = max(maxstr1, maxstr2, maxstr3)
+ # stretching stab
+ maxArray[1] = max(maxadv1, maxadv2, maxadv3)
+
+ return result, maxArray, divergence
+
+ elif (self.choice.find('gradS') >= 0):
+
+ # Ghosts synchronization
+ #OpSynchronize = SynchronizeS(self.topology)
+ #OpSynchronize.apply(self.field2)
+ synchroOp.apply()
+
+ if self.method.find('FD_order2') >= 0:
+ raise ValueError("2nd order scheme Not yet implemented")
+
+ else:
+ # Fourth order scheme
+ temp1 = self.field2[...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field2[ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field2[ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field2[ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+ temp2 = self.field2[...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field2[ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field2[ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field2[ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+ temp3 = self.field2[...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field2[ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field2[ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field2[ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field2[ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+ result = np.array([temp1, temp2, temp3])
+
+ return result
+
+ elif self.choice.find('laplacianV') >= 0:
+
+ # Ghosts synchronization
+# OpSynchronize = Synchronize(self.topology)
+# OpSynchronize.apply(self.field2)
+
+ synchroOp.apply()
+ if self.method.find('FD_order2') >= 0:
+ raise ValueError("2nd order scheme Not yet implemented")
+
+ else:
+## Fourth order scheme for the laplacian operator
+# X components of temp and result
+ temp1 = self.field2[0][...] * 0.
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ - 1. / 12. *
+ self.field2[0][ind0-2, ind1a:ind1b, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[0][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ - 5. / 2. *
+ self.field2[0][ind0+0, ind1a:ind1b, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[0][ind0+1, ind1a:ind1b, ind2a:ind2b] +
+ - 1. / 12. *
+ self.field2[0][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (self.meshSize[0]**2)
+
+ temp2 = self.field2[0][...] * 0.
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1./12. *
+ self.field2[0][ind0a:ind0b, ind1-2, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[0][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ -5. / 2. *
+ self.field2[0][ind0a:ind0b, ind1+0, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[0][ind0a:ind0b, ind1+1, ind2a:ind2b] +
+ -1. / 12. *
+ self.field2[0][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (self.meshSize[1]**2)
+
+ temp3 = self.field2[0][...] * 0.
+ temp3[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-2] +
+ 4. / 3. *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ -5. / 2. *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+0] +
+ 4. / 3. *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+1] +
+ -1. / 12. *
+ self.field2[0][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (self.meshSize[2]**2)
+ temp1 = temp1 + temp2 + temp3
+
+# Y components of temp and result
+ temp4 = self.field2[1][...] * 0.
+ temp4[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[1][ind0-2, ind1a:ind1b, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[1][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ - 5. / 2. *
+ self.field2[1][ind0+0, ind1a:ind1b, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[1][ind0+1, ind1a:ind1b, ind2a:ind2b] +
+ -1. / 12. *
+ self.field2[1][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (self.meshSize[0]**2)
+
+ temp5 = self.field2[1][...] * 0.
+ temp5[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[1][ind0a:ind0b, ind1-2, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[1][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ -5. / 2. *
+ self.field2[1][ind0a:ind0b, ind1+0, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[1][ind0a:ind0b, ind1+1, ind2a:ind2b] +
+ -1. / 12. *
+ self.field2[1][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (self.meshSize[1]**2)
+
+ temp6 = self.field2[1][...] * 0.
+ temp6[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-2] +
+ 4. / 3. *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ -5. / 2. *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+0] +
+ 4. / 3. *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+1] +
+ -1. / 12. *
+ self.field2[1][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (self.meshSize[2]**2)
+ temp4 = temp4 + temp5 + temp6
+
+# Z components of temp and result
+ temp7 = self.field2[2][...] * 0.
+ temp7[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[2][ind0-2, ind1a:ind1b, ind2a:ind2b] +
+ 4./3. *
+ self.field2[2][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ - 5. / 2. *
+ self.field2[2][ind0+0, ind1a:ind1b, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[2][ind0+1, ind1a:ind1b, ind2a:ind2b] +
+ -1. / 12. *
+ self.field2[2][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (self.meshSize[0]**2)
+
+ temp8 = self.field2[2][...] * 0.
+ temp8[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[2][ind0a:ind0b, ind1-2, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[2][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ -5. / 2. *
+ self.field2[2][ind0a:ind0b, ind1+0, ind2a:ind2b] +
+ 4. / 3. *
+ self.field2[2][ind0a:ind0b, ind1+1, ind2a:ind2b] +
+ -1. / 12. *
+ self.field2[2][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (self.meshSize[1]**2)
+
+ temp9 = self.field2[2][...] * 0.
+ temp9[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ -1. / 12. *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-2] +
+ 4. / 3. *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ -5. / 2. *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+0] +
+ 4. / 3. *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+1] +
+ -1. / 12. *
+ self.field2[2][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (self.meshSize[2]**2)
+ temp7 = temp7 + temp8 + temp9
+
+ result = np.concatenate((
+ np.array([temp1]), np.array([temp4]), np.array([temp7])
+ ))
+
+ return result
+
+ elif self.choice.find('curl') >= 0:
+
+ # Ghosts synchronization
+# OpSynchronize = Synchronize(self.topology)
+# OpSynchronize.apply(self.field1)
+
+ synchroOp.apply()
+ if self.method.find('FD_order2') >= 0:
+ raise ValueError("2nd order scheme Not yet implemented")
+
+ else:
+ temp1 = self.field1[0][...] * 0.
+ temp2 = self.field1[0][...] * 0.
+
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[2][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field1[2][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field1[2][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field1[2][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[1][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field1[1][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field1[1][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field1[1][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+ res1 = temp1 - temp2
+
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[0][ind0a:ind0b, ind1a:ind1b, ind2-2] -
+ 8.0 * self.field1[0][ind0a:ind0b, ind1a:ind1b, ind2-1] +
+ 8.0 * self.field1[0][ind0a:ind0b, ind1a:ind1b, ind2+1] -
+ 1.0 * self.field1[0][ind0a:ind0b, ind1a:ind1b, ind2+2]
+ ) / (12. * self.meshSize[2])
+
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[2][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field1[2][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field1[2][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field1[2][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+ res2 = temp1 - temp2
+
+ temp1[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[1][ind0-2, ind1a:ind1b, ind2a:ind2b] -
+ 8.0 * self.field1[1][ind0-1, ind1a:ind1b, ind2a:ind2b] +
+ 8.0 * self.field1[1][ind0+1, ind1a:ind1b, ind2a:ind2b] -
+ 1.0 * self.field1[1][ind0+2, ind1a:ind1b, ind2a:ind2b]
+ ) / (12. * self.meshSize[0])
+
+ temp2[ind0a:ind0b, ind1a:ind1b, ind2a:ind2b] = (
+ 1.0 * self.field1[0][ind0a:ind0b, ind1-2, ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0a:ind0b, ind1-1, ind2a:ind2b] +
+ 8.0 * self.field1[0][ind0a:ind0b, ind1+1, ind2a:ind2b] -
+ 1.0 * self.field1[0][ind0a:ind0b, ind1+2, ind2a:ind2b]
+ ) / (12. * self.meshSize[1])
+ res3 = temp1 - temp2
+ result = np.concatenate((
+ np.array([res1]), np.array([res2]), np.array([res3])
+ ))
+ return result
+
+ else:
+ raise ValueError(
+ "Unknown differiential operator property " +
+ str(self.choice))
+
+ def printComputeTime(self):
+ self.timings_info[0] = "\"Differential Operator total\""
+ self.timings_info[1] = str(self.total_time)
+ self.timings_info[1] += str(self.compute_time[0]) + " " +\
+ str(self.compute_time[1]) + " " + str(self.compute_time[2]) + " "
+ print "Differential Operator total time ind ", self.total_time
+ print "\t Differential Operator ind", self.compute_time
+
+ def __str__(self):
+ s = "DifferentialOperator (DiscreteOperator). " +\
+ DiscreteOperator.__str__(self)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class ind DifferentialOperator"
+ print DifferentialOperator.__doc__
diff --git a/HySoP/unusedOrObsolet/differentialOperator_d.py b/HySoP/unusedOrObsolet/differentialOperator_d.py
new file mode 100755
index 0000000000000000000000000000000000000000..1cf369491e454d6ab73425702c671a5930ce2208
--- /dev/null
+++ b/HySoP/unusedOrObsolet/differentialOperator_d.py
@@ -0,0 +1,443 @@
+# -*- codingind utf-8 -*-
+"""
+@package operator
+Discrete stretching representation
+"""
+from parmepy.constants import np, PARMES_REAL, ORDER
+from parmepy.operator.discrete import DiscreteOperator
+from parmepy.tools.cpu_data_transfer import Synchronize
+import sys
+import time
+import io
+
+
+class DifferentialOperator_d(DiscreteOperator):
+ """
+ Operator representation.
+ DiscreteOperator.DiscreteOperator specialization.
+ """
+
+ def __init__(self, diffop, method=''):
+ """
+ Constructor.
+ Create a Stretching operator on a given continuous domain.
+ Work on a given field2 and field1 to compute the stretching term.
+
+ @param stretch ind Stretching operator.
+ """
+ DiscreteOperator.__init__(self)
+ self.field1 = diffop.field1
+ self.field2 = diffop.field2
+ self.choice = diffop.choice
+ self.compute_time = 0.
+
+ def setUp(self):
+ #La topologie est recuperee des variables discretes
+ self.topology = self.field1.topology
+ self.topology = self.field2.topology
+ self.meshSize = self.topology.mesh.space_step_size
+
+ def apply(self):
+ """
+ Apply operator.
+ """
+ ind0a = self.topology.mesh.local_start[0]
+ ind0b = self.topology.mesh.local_end[0] + 1
+ ind1a = self.topology.mesh.local_start[1]
+ ind1b = self.topology.mesh.local_end[1] + 1
+ ind2a = self.topology.mesh.local_start[2]
+ ind2b = self.topology.mesh.local_end[2] + 1
+ ind0 = np.arange(ind0a,ind0b)
+ ind1 = np.arange(ind1a,ind1b)
+ ind2 = np.arange(ind2a,ind2b)
+
+ if self.choice == 'divWU':
+## second order scheme
+## X components of temp and result
+# temp1 = ( self.field1[0][ind+1,ind,ind] * self.field2[0][ind+1,ind,ind] -\
+# self.field1[0][ind-1,ind,ind] * self.field2[0][ind-1,ind,ind]) / (2. * self.meshSize[0])
+
+# temp2 = (self.field1[1][ind,ind+1,ind] * self.field2[0][ind,ind+1,ind] -\
+# self.field1[1][ind,ind-1,ind] * self.field2[0][ind,ind-1,ind] ) / (2. * self.meshSize[1])
+#
+# temp3 = (self.field1[2][ind,ind,ind+1] * self.field2[0][ind,ind,ind+1] -\
+# self.field1[2][ind,ind,ind-1] * self.field2[0][ind,ind,ind-1] ) / (2. * self.meshSize[2])
+
+# self.result[0][ind,ind]= temp1 + temp2 + temp3
+
+## Y components of temp and result
+# temp1 = (self.field1[0][ind+1,ind,ind] * self.field2[1][ind+1,ind,ind] -\
+# self.field1[0][ind-1,ind,ind] * self.field2[1][ind-1,ind,ind] ) / (2. * self.meshSize[0])
+
+# temp2 = (self.field1[1][ind,ind+1,ind] * self.field2[1][ind,ind+1,ind] -\
+# self.field1[1][ind,ind-1,ind] * self.field2[1][ind,ind-1,ind] ) / (2. * self.meshSize[1])
+#
+# temp3 = (self.field1[2][ind,ind,ind+1] * self.field2[1][ind,ind,ind+1] -\
+# self.field1[2][ind,ind,ind-1] * self.field2[1][ind,ind,ind-1] ) / (2. * self.meshSize[2])
+
+# self.result[1][ind,ind]= temp1 + temp2 +temp3
+
+## Z components of temp and result
+# temp1 = (self.field1[0][ind+1,ind,ind] * self.field2[2][ind+1,ind,ind] -\
+# self.field1[0][ind-1,ind,ind] * self.field2[2][ind-1,ind,ind] ) / (2. * self.meshSize[0])
+
+# temp2 = (self.field1[1][ind,ind+1,ind] * self.field2[2][ind,ind+1,ind] -\
+# self.field1[1][ind,ind-1,ind] * self.field2[2][ind,ind-1,ind] ) / (2. * self.meshSize[1])
+#
+# temp3 = (self.field1[2][ind,ind,ind+1] * self.field2[2][ind,ind,ind+1] -\
+# self.field1[2][ind,ind,ind-1] * self.field2[2][ind,ind,ind-1]) / (2. * self.meshSize[2])
+
+ # Ghosts synchronization
+ linenb = 0
+ if (self.topology.rank == 0):
+ time.sleep(2)
+ print 'Bligne 1', field1[:,linenb,linenb]
+ time.sleep(2)
+ print 'Bligne 2', field1[linenb,:,linenb]
+ time.sleep(2)
+ print 'Bligne 3', field1[linenb,linenb,:]
+ time.sleep(2)
+
+ OpSynchronize = Synchronize(self.topology)
+ OpSynchronize.apply(self.field2, self.field1)
+
+ if (self.topology.rank == 0):
+ time.sleep(2)
+ print 'Aligne 1', field1[:,linenb,linenb]
+ time.sleep(2)
+ print 'Aligne 2', field1[linenb,:,linenb]
+ time.sleep(2)
+ print 'Aligne 3', field1[linenb,linenb,:]
+ time.sleep(2)
+
+# OpSynchronize.apply(self.field2)
+# OpSynchronize.apply(self.field1)
+# X components of temp and result
+ temp1 = (1.0 * self.field1[0][ind0-2,ind1a:ind1b,ind2a:ind2b] * self.field2[0][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1,ind1a:ind1b,ind2a:ind2b] * self.field2[0][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field1[0][ind0+1,ind1a:ind1b,ind2a:ind2b] * self.field2[0][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field1[0][ind0+2,ind1a:ind1b,ind2a:ind2b] * self.field2[0][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+ temp2 = (1.0 * self.field1[1][ind0a:ind0b,ind1-2,ind2a:ind2b] * self.field2[0][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1-1,ind2a:ind2b] * self.field2[0][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1+1,ind2a:ind2b] * self.field2[0][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field1[1][ind0a:ind0b,ind1+2,ind2a:ind2b] * self.field2[0][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+ temp3 = (1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-2] * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-1] * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+1] * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+2] * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ tmp1 = np.array([temp1 + temp2 + temp3])
+
+# Y components of temp and result
+ temp1 = (1.0 * self.field1[0][ind0-2,ind1a:ind1b,ind2a:ind2b] * self.field2[1][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1,ind1a:ind1b,ind2a:ind2b] * self.field2[1][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field1[0][ind0+1,ind1a:ind1b,ind2a:ind2b] * self.field2[1][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field1[0][ind0+2,ind1a:ind1b,ind2a:ind2b] * self.field2[1][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+ temp2 = (1.0 * self.field1[1][ind0a:ind0b,ind1-2,ind2a:ind2b] * self.field2[1][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1-1,ind2a:ind2b] * self.field2[1][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1+1,ind2a:ind2b] * self.field2[1][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field1[1][ind0a:ind0b,ind1+2,ind2a:ind2b] * self.field2[1][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+ temp3 = (1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-2] * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-1] * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+1] * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+2] * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ tmp2 = np.array([temp1 + temp2 + temp3])
+
+# Z components of temp and result
+ temp1 = (1.0 * self.field1[0][ind0-2,ind1a:ind1b,ind2a:ind2b] * self.field2[2][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field1[0][ind0-1,ind1a:ind1b,ind2a:ind2b] * self.field2[2][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field1[0][ind0+1,ind1a:ind1b,ind2a:ind2b] * self.field2[2][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field1[0][ind0+2,ind1a:ind1b,ind2a:ind2b] * self.field2[2][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+ temp2 = (1.0 * self.field1[1][ind0a:ind0b,ind1-2,ind2a:ind2b] * self.field2[2][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1-1,ind2a:ind2b] * self.field2[2][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1+1,ind2a:ind2b] * self.field2[2][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field1[1][ind0a:ind0b,ind1+2,ind2a:ind2b] * self.field2[2][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+ temp3 = (1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-2] * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2-1] * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+1] * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field1[2][ind0a:ind0b,ind1a:ind1b,ind2+2] * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ tmp3 = np.array([temp1 + temp2 + temp3])
+ result = np.concatenate((np.array(tmp1), np.array(tmp2), np.array(tmp3)))
+ return result
+
+ elif self.choice == 'gradV':
+
+ # Ghosts synchronization
+ OpSynchronize = Synchronize(self.topology)
+ OpSynchronize.apply(self.field2)
+
+
+ maxgersh = np.zeros(2, dtype=PARMES_REAL, order=ORDER)
+
+## Fourth order scheme
+# X components of temp and result
+# temp1 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp1 = self.field2[0][...] * 0.
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[0][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field2[0][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field2[0][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field2[0][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+# temp2 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp2 = self.field2[0][...] * 0.
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[0][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field2[0][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field2[0][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field2[0][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+# temp3 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp3 = self.field2[0][...] * 0.
+ temp3[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ maxstr1= np.max(abs(temp1)+abs(temp2)+abs(temp3))
+ maxadv1= np.max(abs(temp1))
+
+# Y components of temp and result
+# temp4 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp4 = self.field2[1][...] * 0.
+ temp4[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[1][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field2[1][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field2[1][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field2[1][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+# temp5 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp5 = self.field2[1][...] * 0.
+ temp5[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[1][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field2[1][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field2[1][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field2[1][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+# temp6 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp6 = self.field2[1][...] * 0.
+ temp6[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ maxstr2= np.max(abs(temp4)+abs(temp5)+abs(temp6))
+ maxadv2= np.max(abs(temp5))
+
+# Z components of temp and result
+# temp7 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp7 = self.field2[2][...] * 0.
+ temp7[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[2][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field2[2][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field2[2][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field2[2][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+# temp8 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp8 = self.field2[2][...] * 0.
+ temp8[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[2][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field2[2][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field2[2][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field2[2][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+# temp9 = np.zeros((self.resolution), dtype=PARMES_REAL, order=ORDER)
+ temp9 = self.field2[2][...] * 0.
+ temp9[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ maxstr3= np.max(abs(temp7)+abs(temp8)+abs(temp9))
+ maxadv3= np.max(abs(temp9))
+ maxgersh[0] = max(maxstr1,maxstr2,maxstr3)
+ maxgersh[1] = max(maxadv1,maxadv2,maxadv3)
+ result = np.concatenate((np.array([temp1, temp2, temp3]),np.array([temp4, temp5, temp6]),np.array([temp7, temp8, temp9])))
+
+ return result, maxgersh
+
+
+ elif self.choice == 'gradS':
+
+ # Ghosts synchronization
+ OpSynchronize = SynchronizeS(self.topology)
+ OpSynchronize.apply(self.field2)
+
+ # Fourth order scheme
+ temp1 = self.field2[...] * 0.
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field2[ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field2[ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field2[ind0+2,ind1a:ind1b,ind2a:ind2b]) / (12. * self.meshSize[0])
+
+ temp2 = self.field2[...] * 0.
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field2[ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field2[ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field2[ind0a:ind0b,ind1+2,ind2a:ind2b]) / (12. * self.meshSize[1])
+
+ temp3 = self.field2[...] * 0.
+ temp3[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field2[ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field2[ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field2[ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field2[ind0a:ind0b,ind1a:ind1b,ind2+2]) / (12. * self.meshSize[2])
+
+ result = np.array([temp1, temp2, temp3])
+
+ return result
+
+ elif self.choice == 'laplacianV':
+
+ # Ghosts synchronization
+ OpSynchronize = Synchronize(self.topology)
+ OpSynchronize.apply(self.field2)
+
+
+## Fourth order scheme for the laplacian operator
+# X components of temp and result
+ temp1 = self.field2[0][...] * 0.
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ (-1./12. * self.field2[0][ind0-2,ind1a:ind1b,ind2a:ind2b] +
+ 4./3. * self.field2[0][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ - 5./2. * self.field2[0][ind0+0,ind1a:ind1b,ind2a:ind2b] +\
+ 4./3. * self.field2[0][ind0+1,ind1a:ind1b,ind2a:ind2b] +\
+ -1./12. * self.field2[0][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (self.meshSize[0]**2)
+
+ temp2 = self.field2[0][...] * 0.
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[0][ind0a:ind0b,ind1-2,ind2a:ind2b] +\
+ 4./3.* self.field2[0][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ -5./2.* self.field2[0][ind0a:ind0b,ind1+0,ind2a:ind2b] +\
+ 4./3.* self.field2[0][ind0a:ind0b,ind1+1,ind2a:ind2b] +\
+ -1./12.* self.field2[0][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (self.meshSize[1]**2)
+
+ temp3 = self.field2[0][...] * 0.
+ temp3[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-2] +\
+ 4./3.* self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ -5./2.* self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+0] +\
+ 4./3.* self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+1] +\
+ -1./12.* self.field2[0][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (self.meshSize[2]**2)
+ temp1 = temp1 + temp2 + temp3
+
+# Y components of temp and result
+ temp4 = self.field2[1][...] * 0.
+ temp4[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ (-1./12. * self.field2[1][ind0-2,ind1a:ind1b,ind2a:ind2b] +
+ 4./3. * self.field2[1][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ - 5./2. * self.field2[1][ind0+0,ind1a:ind1b,ind2a:ind2b] +\
+ 4./3. * self.field2[1][ind0+1,ind1a:ind1b,ind2a:ind2b] +\
+ -1./12. * self.field2[1][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (self.meshSize[0]**2)
+
+ temp5 = self.field2[1][...] * 0.
+ temp5[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[1][ind0a:ind0b,ind1-2,ind2a:ind2b] +\
+ 4./3.* self.field2[1][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ -5./2.* self.field2[1][ind0a:ind0b,ind1+0,ind2a:ind2b] +\
+ 4./3.* self.field2[1][ind0a:ind0b,ind1+1,ind2a:ind2b] +\
+ -1./12.* self.field2[1][ind0a:ind0b,ind1+2,ind2a:ind2b]) / (self.meshSize[1]**2)
+
+ temp6 = self.field2[1][...] * 0.
+ temp6[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-2] +\
+ 4./3.* self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ -5./2.* self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+0] +\
+ 4./3.* self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+1] +\
+ -1./12.* self.field2[1][ind0a:ind0b,ind1a:ind1b,ind2+2]) / (self.meshSize[2]**2)
+ temp4 = temp4 + temp5 + temp6
+
+# Z components of temp and result
+ temp7 = self.field2[2][...] * 0.
+ temp7[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ (-1./12. * self.field2[2][ind0-2,ind1a:ind1b,ind2a:ind2b] +
+ 4./3. * self.field2[2][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ - 5./2. * self.field2[2][ind0+0,ind1a:ind1b,ind2a:ind2b] +\
+ 4./3. * self.field2[2][ind0+1,ind1a:ind1b,ind2a:ind2b] +\
+ -1./12. * self.field2[2][ind0+2,ind1a:ind1b,ind2a:ind2b]) / (self.meshSize[0]**2)
+
+ temp8 = self.field2[2][...] * 0.
+ temp8[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[2][ind0a:ind0b,ind1-2,ind2a:ind2b] +\
+ 4./3.* self.field2[2][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ -5./2.* self.field2[2][ind0a:ind0b,ind1+0,ind2a:ind2b] +\
+ 4./3.* self.field2[2][ind0a:ind0b,ind1+1,ind2a:ind2b] +\
+ -1./12.* self.field2[2][ind0a:ind0b,ind1+2,ind2a:ind2b]) / ( self.meshSize[1]**2)
+
+ temp9 = self.field2[2][...] * 0.
+ temp9[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = \
+ ( -1./12.* self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-2] +\
+ 4./3.* self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ -5./2.* self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+0] +\
+ 4./3.* self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+1] +\
+ -1./12.* self.field2[2][ind0a:ind0b,ind1a:ind1b,ind2+2]) / ( self.meshSize[2]**2)
+ temp7 = temp7 + temp8 + temp9
+
+ result = np.concatenate((np.array([temp1]),np.array([temp4]),np.array([temp7])))
+
+ return result
+
+
+ elif self.choice == 'curl':
+
+ OpSynchronize = Synchronize(self.topology)
+ OpSynchronize.apply(self.field1)
+
+ temp1 = self.field1[0][...] * 0.
+ temp2 = self.field1[0][...] * 0.
+
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[2][ind0a:ind0b,ind1-2,ind2a:ind2b] -
+ 8.0 * self.field1[2][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field1[2][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field1[2][ind0a:ind0b,ind1+2,ind2a:ind2b] ) / (12. * self.meshSize[1])
+
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[1][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field1[1][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field1[1][ind0a:ind0b,ind1a:ind1b,ind2+2] ) / (12. * self.meshSize[2])
+ res1 = temp1 - temp2
+
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[0][ind0a:ind0b,ind1a:ind1b,ind2-2] -\
+ 8.0 * self.field1[0][ind0a:ind0b,ind1a:ind1b,ind2-1] +\
+ 8.0 * self.field1[0][ind0a:ind0b,ind1a:ind1b,ind2+1] -\
+ 1.0 * self.field1[0][ind0a:ind0b,ind1a:ind1b,ind2+2] ) / (12. * self.meshSize[2])
+
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[2][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field1[2][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field1[2][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field1[2][ind0+2,ind1a:ind1b,ind2a:ind2b] ) / (12. * self.meshSize[0])
+ res2 = temp1 - temp2
+
+ temp1[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[1][ind0-2,ind1a:ind1b,ind2a:ind2b] -
+ 8.0 * self.field1[1][ind0-1,ind1a:ind1b,ind2a:ind2b] +\
+ 8.0 * self.field1[1][ind0+1,ind1a:ind1b,ind2a:ind2b] -\
+ 1.0 * self.field1[1][ind0+2,ind1a:ind1b,ind2a:ind2b] ) / (12. * self.meshSize[0])
+
+ temp2[ind0a:ind0b,ind1a:ind1b,ind2a:ind2b] = (1.0 * self.field1[0][ind0a:ind0b,ind1-2,ind2a:ind2b] -\
+ 8.0 * self.field1[0][ind0a:ind0b,ind1-1,ind2a:ind2b] +\
+ 8.0 * self.field1[0][ind0a:ind0b,ind1+1,ind2a:ind2b] -\
+ 1.0 * self.field1[0][ind0a:ind0b,ind1+2,ind2a:ind2b] ) / (12. * self.meshSize[1])
+ res3 = temp1 - temp2
+ result = np.concatenate((np.array([res1]), np.array([res2]), np.array([res3])))
+ return result
+
+ else:
+ raise ValueError("Unknown differiential operatorind " + str(self.choice))
+
+ def printComputeTime(self):
+ self.timings_info[0] = "\"Differential Operator total\""
+ self.timings_info[1] = str(self.total_time)
+ self.timings_info[1] += str(self.compute_time[0]) + " " + str(self.compute_time[1]) + " " + str(self.compute_time[2]) + " "
+ print "Differential Operator total time ind ", self.total_time
+ print "\t Differential Operator ind", self.compute_time
+
+
+ def __str__(self):
+ s = "DifferentialOperator_d (DiscreteOperator). " + DiscreteOperator.__str__(self)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class ind DifferentialOperator_d"
+ print DifferentialOperator_d.__doc__
diff --git a/HySoP/unusedOrObsolet/discrete.py b/HySoP/unusedOrObsolet/discrete.py
new file mode 100644
index 0000000000000000000000000000000000000000..6023b35c7e682262f383b20ec778e7fff8c565c9
--- /dev/null
+++ b/HySoP/unusedOrObsolet/discrete.py
@@ -0,0 +1,121 @@
+"""
+@package parmepy.problem.discrete
+
+Problem representation.
+"""
+from ..Param import *
+
+
+class DiscreteProblem:
+ """
+ Abstract description of discrete problem.
+ """
+
+ def __init__(self):
+ """
+ Create an empty discerte problem.
+ """
+ print "DISCRETE PROBLEM"
+ ## Domains of the problem.
+ self.domains = []
+ ## Variables of the problem.
+ self.variables = []
+ ## Operators of the problem.
+ self.operators = []
+ ## Problem solver
+ self.solver = None
+ ## Results printer
+ self.printer = None
+
+ def addDomain(self, cDomain):
+ """
+ Add a DiscreteDomain.DiscreteDomain to the problem.
+
+ @param cDomain DiscreteDomain.DiscreteDomain : list of domains to add.
+ """
+ print "Add domain"
+ for d in cDomain:
+ if self.domains.count(d) == 0:
+ self.domains.append(d)
+
+ def addVariable(self, cVariable):
+ """
+ Add a DiscreteVariable.DiscreteVariable to the problem.
+ Also add variables' domains to the problem.
+
+ @param cVariable DiscreteVariable.DiscreteVariable : list of variables to add.
+ """
+ print "add variable"
+ for v in cVariable:
+ if self.variables.count(v) == 0:
+ self.variables.append(v)
+ if self.domains.count(v.domain) == 0:
+ self.domains.append(v.domain)
+
+ def addOperator(self, cOperator, index=None):
+ """
+ Add a DiscreteOperator.DiscreteOperator to the problem.
+ Also add operators' variables and variables' domains to the problem.
+
+ @param cOperator DiscreteOperator.DiscreteOperator : list od operators to add.
+ """
+ print "add operator"
+ if isinstance(cOperator, list):
+ for i,o in enumerate(cOperator):
+ if self.operators.count(o) == 0:
+ try:
+ self.operators.insert(index[i],o)
+ except TypeError:
+ self.operators.append(o)
+ for v in o.variables:
+ if self.variables.count(v) == 0:
+ self.variables.append(v)
+ if self.domains.count(v.domain) == 0:
+ self.domains.append(v.domain)
+ else:
+ if self.operators.count(cOperator) == 0:
+ print index
+ try:
+ self.operators.insert(index, cOperator)
+ except TypeError:
+ self.operators.append(cOperator)
+ for v in cOperator.variables:
+ if self.variables.count(v) == 0:
+ self.variables.append(v)
+ if self.domains.count(v.domain) == 0:
+ self.domains.append(v.domain)
+
+ def setSolver(self, solver):
+ """
+ Set solver for the discrete problem.
+
+ @param solver : Solver.Solver to use.
+ """
+ print "set solver"
+ self.solver = solver
+ self.solver.initialize()
+
+ def setPrinter(self, printer):
+ """
+ Set results printer.
+
+ @param printer : Printer.Printer to use.
+ """
+ print "set printer"
+ self.printer = printer
+
+ def solve(self, T, dt):
+ """
+ Abstract method.
+ Must be implemented by sub-class.
+
+ @param T : Simulation final time.
+ @param dt : Simulation time step.
+ """
+ raise NotImplementedError("Need to override method in a subclass of " + providedClass)
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : DiscreteProblem"
+ print DiscreteProblem.__doc__
diff --git a/HySoP/unusedOrObsolet/forward_euler.py b/HySoP/unusedOrObsolet/forward_euler.py
new file mode 100644
index 0000000000000000000000000000000000000000..9e95c38dd3b908aeed0de989e5a77fe182e2240f
--- /dev/null
+++ b/HySoP/unusedOrObsolet/forward_euler.py
@@ -0,0 +1,54 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+Forward Euler method.
+"""
+from ODESolver import ODESolver
+
+
+providedClass = "ForwardEuler"
+
+
+class ForwardEuler(ODESolver):
+ """
+ ODESolver implementation for solving an equation system with forward Euler method.
+ y'(t) = f(t,y)
+
+ y(t_{n+1}) = y(t_n) + dt*f(y(t_n))
+
+ """
+ def __init__(self, f=None, dim=1, conditions=lambda x: x):
+ """
+ Constructor.
+
+ @param f function f(t,y) : Right hand side of the equation to solve.
+ @param dim : dimensions
+ @param conditions : function to apply boundary conditions.
+ """
+ ODESolver.__init__(self, f)
+ # Boundary conditions function.
+ self.boundaryConditions = conditions
+ # Integration methods for each direction.
+ self.integrate = [self._integrate for i in xrange(dim)]
+
+ def _integrate(self, y, t, dt):
+ """
+ Integration step for forward Euler method.
+ y(t_{n+1}) = y(t_n) + dt*f(y(t_n))
+
+ @param y : position at time t.
+ @param t : current time.
+ @param dt : time step.
+ @return y at t+dt.
+ """
+ return [y[i] + dt * self.f(t, y, i)[i] for i in xrange(len(y))]
+
+ def __str__(self):
+ """ToString method"""
+ return "Forward Euler Method"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
diff --git a/HySoP/unusedOrObsolet/gpu_analytic.py b/HySoP/unusedOrObsolet/gpu_analytic.py
new file mode 100644
index 0000000000000000000000000000000000000000..5832a863e968a822d11052da3a53e7093be4f604
--- /dev/null
+++ b/HySoP/unusedOrObsolet/gpu_analytic.py
@@ -0,0 +1,114 @@
+"""
+@file gpu_analytic.py
+Analytic operator on GPU.
+"""
+from parmepy.operator.discrete.discrete import DiscreteOperator
+from parmepy.constants import debug, np, PARMES_INDEX, S_DIR
+from parmepy import __VERBOSE__
+from parmepy.gpu.tools import get_opencl_environment
+from parmepy.gpu.gpu_kernel import KernelLauncher
+from parmepy.tools.timers import timed_function
+from parmepy.methods_keys import Support
+from parmepy.tools.timers import Timer
+
+
+class GPUAnalytic(DiscreteOperator):
+ """
+ Analytic operator on GPU.
+
+ Evaluates a formula on a GPU field.
+ """
+
+ @debug
+ def __init__(self, variables,
+ platform_id=0, device_id=0,
+ device_type='gpu',
+ method={Support: 'gpu'}, src=None, precision=None):
+ """
+ Constructor.
+
+ Computes the OpenCL environment with
+ parmepy.gpu.tools.get_opencl_environment.
+
+ @param variables a list of discrete variables
+ @param platform_id OpenCL platform id
+ @param device_id OpenCL device id
+ @param device_type OpenCL device type
+ @param method Method to use
+ @param src User OpenCL source file
+ @param precision Floating point precision
+ """
+ DiscreteOperator.__init__(self, variables, method)
+ ## OpenCL work-item number
+ self.workItemNumber = 0
+ ## Operated field
+ self.field = self.variables[0]
+ ## User source file
+ self.usr_src = src
+ ## Field resolution
+ self.resolution = self.field.topology.mesh.resolution
+ ## OpenCL environment
+ self.cl_env = get_opencl_environment(platform_id, device_id,
+ device_type, precision)
+ self.numMethod = None
+ ## Object to store computational times of OpenCL kernels
+ self.kernels_timer = Timer(self)
+
+ @debug
+ def setUp(self):
+ """
+ Set up.
+ Compute OpenCL work-item number and space index.\n
+ Compile OpenCL sources. The OpenCL kernel mus be named as follows :
+ <code>analytic"FieldName"</code> with <code>"FieldName"</code> is the
+ name of the field as given by user.
+ """
+ ## Floating point precision
+ self.gpu_precision = self.cl_env.precision
+ ## OpenCL space index
+ self.workItemNumber, self.gwi, self.lwi = self.cl_env.get_WorkItems(
+ self.resolution)
+ if __VERBOSE__:
+ print "Work-items basic config : ",
+ print self.workItemNumber, self.gwi, self.lwi
+ dim = self.field.dimension
+ ## Minimum field coordinate (as GPU float4)
+ self.coord_min = np.ones(4, dtype=self.gpu_precision)
+ ## Field mesh size (as GPU float4)
+ self.mesh_size = np.ones(4, dtype=self.gpu_precision)
+ self.coord_min[0:dim] = np.asarray(self.field.topology.mesh.origin,
+ dtype=self.gpu_precision)
+ self.mesh_size[0:dim] = np.asarray(self.field.topology.mesh.space_step,
+ dtype=self.gpu_precision)
+ # Kernel sources
+ if __VERBOSE__:
+ print "=== Kernel sources ==="
+ ## OpenCL compiling options
+ self.build_options = ""
+ resol = np.ones((3,), dtype=PARMES_INDEX)
+ resol[:dim] = self.resolution[...]
+ for i in xrange(3):
+ self.build_options += " -D NB" + S_DIR[i] + "=" + str(resol[i])
+ self.build_options += " -D WI_NB=" + str(self.workItemNumber)
+ ## OpenCL Binaries
+ if self.usr_src is not None:
+ self.prg = self.cl_env.build_src(self.usr_src, self.build_options)
+ kernel_name = 'analytic' + self.field.name.rsplit('_', 1)[0]
+ self.numMethod = KernelLauncher(eval('self.prg.' + kernel_name),
+ self.cl_env.queue,
+ self.gwi, self.lwi)
+
+ @debug
+ @timed_function
+ def apply(self, simulation):
+ t = self.gpu_precision(simulation.time)
+ self.field.initialize(self.numMethod, t)
+ if self.numMethod is None:
+ self.field.toDevice()
+
+ def finalize(self):
+ if self.numMethod is not None and self.numMethod.f_timer is not None:
+ for f_timer in self.numMethod.f_timer:
+ self.kernels_timer.addFunctionTimer(f_timer)
+ self.timer.addSubTimer(self.kernels_timer, 'Details:')
+ DiscreteOperator.finalize(self)
diff --git a/HySoP/unusedOrObsolet/obstacle_d_old.py b/HySoP/unusedOrObsolet/obstacle_d_old.py
new file mode 100644
index 0000000000000000000000000000000000000000..5985ef29307a7d9e2b9496a1b7d71f2ee3c6cecd
--- /dev/null
+++ b/HySoP/unusedOrObsolet/obstacle_d_old.py
@@ -0,0 +1,157 @@
+"""
+Discrete obstacles description
+@todo write test in parmepy/domain/test/test_obstacle.py
+"""
+from parmepy.constants import np
+
+
+class Obstacle_d(object):
+ """
+ Discrete obstacles representation.
+ """
+
+ def __init__(self, parent, topology=None, name='sphere', idFromParent=None):
+ """
+ Creates discrete obsctacle and z-boundaries and returns 3 arrays corresponding
+ to the three different porous media.
+ porosity in the solid = 0
+ porosity in the fluid = infinity
+
+ @param parent : Continuous obstacle.
+ @param topology : Topology informations
+ @param name : Obstacle name
+ @param idFromParent : Index in the parent's discrete obstacles
+ """
+
+ ## Topology of the obstacle
+ if(topology is not None):
+ self.topology = topology
+ else:
+ raise NotImplementedError()
+ ## Name of the obstacle
+ self.name = name
+ ## Obstacle dimension
+ self.dimension = topology.domain.dimension
+ ## Obstacle resolution
+ self.resolution = topology.mesh.resolution
+ ## @private Continuous obstacle
+ self.__parentObstacle = parent
+ ## @private Index in parent's discrete obstacle
+ self.__idFromParent = idFromParent
+ ## Width of z-boundaries layer
+ self.zlayer = self.__parentObstacle.zlayer
+ ## Radius of the obstacle
+ self.radius = self.__parentObstacle.radius
+ ## Position of the obstacle center
+ self.center = self.__parentObstacle.center
+ ## Orientation of the obstacle
+ self.orientation = self.__parentObstacle.orientation
+ ## Thickness of the porous layer at the obstacle surface
+ self.porousLayer = self.__parentObstacle.porousLayer
+ ## Chi function (array) for z-boundaries
+ self.chiBoundary = None
+ ## Chi function (array) for the solid
+ self.chiSolid = None
+ ## Chi function (array) for the porous area
+ self.chiPorous = None
+ ## Determine characteristic function Chi of Obstacle
+ self.chiFunctions()
+
+ def chiFunctions(self):
+ """
+ Compute the chi functions associated to z-boundaries and solid
+ """
+# boolOrientation=[np.bool(0) for i in range (6)]
+# boolOrientation[self.indOrientation(self.orientation)]=True
+
+ ## Temporary arrays
+ chiBoundary_i = []
+ chiBoundary_j = []
+ chiBoundary_k = []
+ chiSolid_i = []
+ chiSolid_j = []
+ chiSolid_k = []
+ chiPorous_i = []
+ chiPorous_j = []
+ chiPorous_k = []
+
+ step = self.topology.mesh.space_step_size
+ ghosts = self.topology.ghosts
+ coord_start = self.topology.mesh.origin
+ coord_end = self.topology.mesh.end * step + self.topology.domain.origin - (ghosts * step)
+ layerMin = coord_start[2] + ghosts[2] * step[2] + self.zlayer
+ layerMax = coord_end[2] - ghosts[2] * step[2] - self.zlayer
+ radiusMinuslayer = self.radius- self.porousLayer
+ print 'start, end, layerMin, layerMax', coord_start, coord_end, layerMin, layerMax
+ for k in xrange (ghosts[2], self.resolution[2] - ghosts[2]):
+ rz = coord_start[2] + step[2] * k
+ for j in xrange (ghosts[1], self.resolution[1] - ghosts[1]):
+ ry = coord_start[1] + step[1] * j
+ for i in xrange (ghosts[0], self.resolution[0] - ghosts[0]):
+ if (rz > layerMax or rz < layerMin):
+ # we are in the z-layer (North or South):
+# chiBoundaryTmp.append([i,j,k])
+ chiBoundary_i.append(i)
+ chiBoundary_j.append(j)
+ chiBoundary_k.append(k)
+ else :
+ rx = coord_start[0] + step[0] * i
+ dist = np.sqrt((rx - self.center[0]) **2 +
+ (ry - self.center[1]) **2 +
+ (rz - self.center[2]) **2)
+# if (self.name=='sphere'):
+ if (radiusMinuslayer < dist and dist <= self.radius + 1E-12 and self.porousLayer != 0.):
+ # we are in the porous area of the sphere:
+# chiPorousTmp.append([i,j,k])
+ chiPorous_i.append(i)
+ chiPorous_j.append(j)
+ chiPorous_k.append(k)
+ if (dist <= radiusMinuslayer + 1E-12):
+ # we are in the solid area of the sphere:
+# chiSolidTmp.append([i,j,k])
+ chiSolid_i.append(i)
+ chiSolid_j.append(j)
+ chiSolid_k.append(k)
+# else :
+# if (radiusMinuslayer < dist and dist <= self.radius and rx <= self.center[0]):
+# # we are in the porous area of the hemisphere:
+## chiPorousTmp.append([i,j,k])
+# chiPorous_i.append(i)
+# chiPorous_j.append(j)
+# chiPorous_k.append(k)
+# if (dist <= radiusMinuslayer and rx <= self.center[0]):
+# # we are in the solid area of the hemisphere:
+## chiSolidTmp.append([i,j,k])
+# chiSolid_i.append(i)
+# chiSolid_j.append(j)
+# chiSolid_k.append(k)
+
+ ## Characteristic function of penalized boundaries
+ chiBoundary_i = np.asarray(chiBoundary_i)
+ chiBoundary_j = np.asarray(chiBoundary_j)
+ chiBoundary_k = np.asarray(chiBoundary_k)
+ self.chiBoundary = chiBoundary(chiBoundary_i, chiBoundary_j, chiBoundary_k)
+
+ ## Characteristic function of solid areas
+ chiSolid_i = np.asarray(chiSolid_i)
+ chiSolid_j = np.asarray(chiSolid_j)
+ chiSolid_k = np.asarray(chiSolid_k)
+ self.chiSolid = chiSolid(chiSolid_i, chiSolid_j, chiSolid_k)
+
+ ## Characteristic function of porous areas
+ chiPorous_i = np.asarray(chiPorous_i)
+ chiPorous_j = np.asarray(chiPorous_j)
+ chiPorous_k = np.asarray(chiPorous_k)
+ self.chiPorous = chiPorous(chiPorous_i, chiPorous_j, chiPorous_k)
+
+
+ def indOrientation(orientation):
+ return {'West':0, 'East':1, 'South':2, 'North':3, 'Forward':4, 'Backward':5}.get(orientation, 0)
+
+ def __str__(self):
+ """ToString method"""
+ return "Obstacle_d (discrete obstacles)"
+
+if __name__ == "__main__" :
+ print "This module defines the following classes:"
+ print "Obstacle_d: ", Obstacle_d.__doc__
diff --git a/HySoP/unusedOrObsolet/obstacle_old.py b/HySoP/unusedOrObsolet/obstacle_old.py
new file mode 100644
index 0000000000000000000000000000000000000000..db9342b21f7b0b17659e521f8d7ad6c821613b83
--- /dev/null
+++ b/HySoP/unusedOrObsolet/obstacle_old.py
@@ -0,0 +1,72 @@
+"""
+Obstacles representation.
+"""
+from parmepy.constants import np, PARMES_REAL
+from obstacle_d import Obstacle_d
+
+
+class Obstacle(object):
+ """
+ Obstacles representation.
+ """
+
+ def __init__(self, domain, name='sphere', zlayer=0.001, radius=0.05,
+ center=[0.5, 0.5, 0.5], orientation='West',
+ porousLayer=0.001):
+ """
+ Constructor.
+ Create an obsctacle and z-boundaries from given parameters :
+
+ @param domain : obstacle application domain.
+ @param name : name of the obstacle ("sphere" or "hemisphere")
+ @param zlayer : width of z-boundaries layer
+ @param radius : radius of the obstacle
+ @param center : position of the obstacle center
+ """
+ ## Application domain of the obstacle
+ self.domain = domain
+ ## Obstacle dimension.
+ self.dimension = self.domain.dimension
+ ## Obstacle discretisation
+ self.discreteObstacle = None
+ ## Number of different discretizations
+ self._obstacleId = -1
+ ## List of the various discretizations of the obstacle
+ self.discreteObstacle = []
+ ## Obstacle name
+ self.name = name
+ ## Width of z-boundaries layer
+ self.zlayer = zlayer
+ ## Obstacle radius
+ self.radius = radius
+ ## Position of the obstacle center
+ self.center = np.asarray(center, dtype=PARMES_REAL)
+ ## Obstacle orientation
+ self.orientation = orientation
+ ## Thickness of the porous layer at the obstacle surface
+ self.porousLayer = porousLayer
+
+ def discretize(self, topology=None):
+ """
+ Obstacle discretization method.
+ """
+ self._obstacleId += 1
+ self.discreteObstacle.append(Obstacle_d(self, topology,
+ name=self.name,
+ idFromParent=self._obstacleId))
+
+ def __str__(self):
+ """ Obstacle info display """
+ s = self.name + ' , ' + str(self.dimension) + 'D obstacle '
+ if len(self.Obstacle_d) != 0:
+ s += "with the following discretizations:\n"
+ for i in range(len(self.Obstacle_d)):
+ s += self.Obstacle_d[i].__str__()
+ else:
+ s += ". Not discretised\n"
+ return s
+
+if __name__ == "__main__" :
+ print __doc__
+ print "- Provided class : Obstacle"
+ print Obstacle.__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/__init__.py b/HySoP/unusedOrObsolet/particular_solvers/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..8a853e394e565707c4ae5d64b74ec2542117ae39
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/__init__.py
@@ -0,0 +1,6 @@
+"""
+@package parmepy.particular_solvers
+
+Everything concerning particle solvers.
+
+"""
diff --git a/HySoP/unusedOrObsolet/particular_solvers/basic.py b/HySoP/unusedOrObsolet/particular_solvers/basic.py
new file mode 100644
index 0000000000000000000000000000000000000000..01e24a6e7aa968916b275f527433096ae322c556
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/basic.py
@@ -0,0 +1,168 @@
+"""
+@package parmepy.particular_solvers.basic
+
+Particular solver description.
+"""
+from solver import Solver
+from parmepy.fields.continuous import ContinuousField
+from parmepy.operator.transport import Transport
+from parmepy.operator.stretching import Stretching
+from parmepy.operator.remeshing import Remeshing
+from parmepy.operator.penalization import Penalization
+from parmepy.operator.advec_scales import Advec_scales
+from parmepy.operator.diffusion import Diffusion
+from parmepy.operator.poisson import Poisson
+from parmepy.operator.splitting import Splitting
+from parmepy.tools.timer import Timer
+from parmepy.tools.printer import Printer
+from parmepy.integrator import RK3
+
+
+class ParticleSolver(Solver):
+ """
+ Particular solver description.
+
+ Link with differents numericals methods used.
+ """
+ def __init__(self, problem, t_end, dt,
+ ODESolver=RK3,
+ InterpolationMethod=None,
+ RemeshingMethod=None,
+ splittingMethod='strang',
+ timer=None,
+ io=None):
+ """
+ Create a solver description.
+
+ @param problem : problen that solve this solver.
+ @param t_end : Simulation final time.
+ @param dt : Simulation time step.
+ @param ODESolver : ODE solver method.
+ @param InterpolationMethod : Interpolation method.
+ @param RemeshingMethod : Remeshing method.
+ @param splittingMethod : Splitting type.
+ @param timer : Simulation time step manager.
+ @param io : Simulation io manager.
+ """
+ Solver.__init__(self, problem)
+ ## Advection operator of the problem. Advection need special
+ ## treatment in particle methods.
+ self.advection = None
+ self.stretch = None
+ self.penal = None
+ self.advec_scales = None
+ self.diffusion = None
+ self.poisson = None
+ ## ODE Solver method.
+ self.ODESolver = ODESolver
+ ## Interpolation method.
+ self.InterpolationMethod = InterpolationMethod
+ ## Remeshing method.
+ self.RemeshingMethod = RemeshingMethod
+ ## Splitting Method
+ self.splittingMethod = splittingMethod
+ ## Is solver initialized
+ self.isInitialized = False
+ if timer is None:
+ self.problem.setTimer(Timer(t_end, dt))
+ else:
+ self.problem.setTimer(timer)
+ if io is None:
+ self.problem.setIO(Printer())
+ else:
+ self.problem.setIO(io)
+ for op in self.problem.operators:
+ if isinstance(op, Transport):
+ self.advection = op
+ if isinstance(op, Stretching):
+ self.stretch = op
+ if isinstance(op, Penalization):
+ self.penal = op
+ if isinstance(op, Advec_scales):
+ self.advec_scales = op
+ if isinstance(op, Diffusion):
+ self.diffusion = op
+ if isinstance(op, Poisson):
+ self.poisson = op
+ #if isinstance(op, Velocity)
+ #self.velocity = op
+ #if self.advection is None:
+ # raise ValueError("Particular Solver :
+ # Cannot create from a problem with no Transport operator")
+
+ def initialize(self):
+ """
+ Solver initialisation.
+ Initialize a particle method solver regarding the problem.
+ """
+ self.p_position = ContinuousField(domain=self.problem.domains[0],
+ name='ParticlePosition')
+ self.p_scalar = ContinuousField(domain=self.problem.domains[0],
+ name='ParticleScalar')
+ self.problem.addVariable([self.p_position, self.p_scalar])
+ ## Discretise domains
+ ## Note FP : this is probably useless???
+ #for d in self.problem.domains:
+ # d.discretize(self.problem.topology.globalMeshResolution)
+ ## Discretise fields and initialize
+ for v in self.problem.variables:
+ v.discretize(self.problem.topology)
+ print "=== Fields initialization ==="
+ for v in self.problem.variables:
+ v.initialize()
+ print "==\n"
+ ## Discretise operators
+ for op in self.problem.operators:
+ if op is self.advection:
+ op.discretize(result_position=self.p_position,
+ result_scalar=self.p_scalar,
+ method=self.ODESolver)
+ if op is self.stretch:
+ op.discretize(topology=self.problem.topology,
+ method=self.ODESolver)
+ if op is self.penal:
+ op.obstacle.discretize(self.problem.topology)
+ op.discretize()
+ if op is self.advec_scales:
+ op.discretize(topology=self.problem.topology)
+ if op is self.diffusion:
+ op.discretize(topology=self.problem.topology)
+ if op is self.poisson:
+ op.discretize(topology=self.problem.topology)
+ ## Velocity is only program on gpu for instance
+ #elif op is self.velocity:
+ # op.discretize(result_position=self.p_position,
+ # result_scalar=self.p_scalar, method=self.ODESolver)
+ else:
+ op.discretize()
+ if self.advection is not None and not self.advection.include_remesh:
+ ## Create remeshing operator
+ self.remeshing = Remeshing(
+ partPositions=self.advection.discreteOperator.res_position,
+ partScalar=self.advection.discreteOperator.res_scalar,
+ resscal=self.advection.discreteOperator.scalar,
+ method=self.RemeshingMethod)
+
+ for op in self.problem.operators:
+ if op.needSplitting:
+ index = self.problem.operators.index(op)
+ if op is self.advection and not self.advection.include_remesh:
+ self.problem.operators[index] = Splitting(
+ [op, self.remeshing], dim=self.problem.topology.dim)
+ else:
+ self.problem.operators[index] = Splitting(
+ [op], dim=self.problem.topology.dim)
+ self.isInitialized = True
+
+ def end(self):
+ """\todo : Put here memory free instructions"""
+
+ def __str__(self):
+ """ToString method"""
+ s = " Particle solver "
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : ParticleSolver"
+ print ParticleSolver.__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu.py b/HySoP/unusedOrObsolet/particular_solvers/gpu.py
new file mode 100644
index 0000000000000000000000000000000000000000..f0c9f39c373c1ef4daabff90cf871fb25d44fc1b
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu.py
@@ -0,0 +1,638 @@
+"""
+@package parmepy.particular_solvers.gpu
+
+Particular solver description. Computations are performed on GPU device.
+"""
+from ..constants import *
+from basic import ParticleSolver
+from ..fields.continuous import ContinuousField
+from ..operator.transport import Transport
+from ..operator.remeshing import Remeshing
+from ..operator.splitting import Splitting
+from ..tools.timer import Timer
+from ..tools.printer import Printer
+import pyopencl as cl
+from ..tools.gpu_data_transfer import hostToDevice
+from ..tools.gpu_data_transfer import deviceToHost
+
+
+class GPUParticleSolver(ParticleSolver):
+ """
+ GPU Particular solver description.
+
+ Link with differents numericals methods used.
+ Prepare GPU side (memory, kernels, ...)
+ """
+ def __init__(self, problem, t_end, dt,
+ ODESolver=None,
+ InterpolationMethod=None,
+ RemeshingMethod=None,
+ splittingMethod='strang',
+ timer=None,
+ io=None,
+ platform_id=0, device_id=0,
+ device_type='gpu',
+ src=None,
+ precision=PARMES_REAL_GPU):
+ """
+ @copydoc ParticleSolver.__init__()
+ @param platform_id : OpenCL platform id to use.
+ @param device_id : OpenCL device id to use.
+ @param device_type='gpu' : OpenCL device type to use.
+ @param src : OpenCL kernel sources given by user.
+
+ Discover OpenCL environment.
+ """
+ ParticleSolver.__init__(self, problem, t_end, dt,
+ ODESolver=ODESolver,
+ InterpolationMethod=InterpolationMethod,
+ RemeshingMethod=RemeshingMethod,
+ splittingMethod=splittingMethod,
+ timer=timer,
+ io=io)
+ ## User kernel sources filename
+ self.user_gpu_src = src
+ self.gpu_precision = precision
+ print "=== OpenCL environment ==="
+ #Get platform.
+ try:
+ ## OpenCL platform
+ self.platform = cl.get_platforms()[platform_id]
+ except IndexError:
+ print " Incorrect platform_id :", platform_id, ".",
+ print " Only ", len(cl.get_platforms()), " available.",
+ print " Getting defalut platform. "
+ self.platform = cl.get_platforms()[0]
+ print " Platform "
+ print " - Name :", self.platform.name
+ print " - Version :", self.platform.version
+ #Get device.
+ try:
+ ## OpenCL device
+ self.device = self.platform.get_devices(
+ eval("cl.device_type." + device_type.upper()))[device_id]
+ except cl.RuntimeError as e:
+ print "RuntimeError:", e
+ self.device = cl.create_some_context().devices[0]
+ except AttributeError as e:
+ print "AttributeError:", e
+ self.device = cl.create_some_context().devices[0]
+ print " Device"
+ print " - Name :",
+ print self.device.name
+ print " - Type :",
+ print cl.device_type.to_string(self.device.type)
+ print " - C Version :",
+ print self.device.opencl_c_version
+ print " - Global mem size :",
+ print self.device.global_mem_size / (1024 ** 3), "GB"
+ print "===\n"
+ #Creates GPU Context
+ ## OpenCL context
+ self.ctx = cl.Context([self.device])
+ #Create CommandQueue on the GPU Context
+ ## OpenCL command queue
+ self.queue = cl.CommandQueue(
+ self.ctx, properties=cl.command_queue_properties.PROFILING_ENABLE)
+
+ def initialize(self):
+ """
+ @copydoc ParticleSolver.initialize(self)
+ Compile kernel sources. \n
+ Allocate device memory as OpenCL Buffers.\n
+ Initialize memory on device. \n
+ Link kernels ans parmepy.operators.
+ @todo : Take non square resolutions
+ """
+ ParticleSolver.initialize(self)
+ # kernels compilation
+ print "=== Kernel sources compiling ==="
+ self.gpu_src = ""
+ if self.user_gpu_src is not None:
+ if isinstance(self.user_gpu_src, list):
+ for user_src in self.user_gpu_src:
+ print "Sources files (user): ", user_src
+ f = open(user_src, 'r')
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ else:
+ print "Sources files (user): ", self.user_gpu_src
+ f = open(self.user_gpu_src, 'r')
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ resolution = self.problem.topology.mesh.resolution
+ ## Optimal work item number
+ if len(resolution) == 3:
+ workItemNumber = 64
+ else:
+ workItemNumber = 256
+ print " Work-Item number: ", workItemNumber
+ ## Precision supported
+ print " Precision capability ",
+ self.correctlyroundeddividesqrt = True
+ if self.gpu_precision is np.float32:
+ print "for Single Precision: "
+ for v in ['DENORM', 'INF_NAN',
+ 'ROUND_TO_NEAREST', 'ROUND_TO_ZERO', 'ROUND_TO_INF',
+ 'FMA', 'CORRECTLY_ROUNDED_DIVIDE_SQRT', 'SOFT_FLOAT']:
+ try:
+ if eval('(self.device.single_fp_config &' +
+ ' cl.device_fp_config.' +
+ v + ') == cl.device_fp_config.' + v):
+ print v
+ except AttributeError as ae:
+ if v is 'CORRECTLY_ROUNDED_DIVIDE_SQRT':
+ self.correctlyroundeddividesqrt = False
+ print v, 'is not supported in OpenCL C 1.2.\n',
+ print ' Exception catched : ', ae
+ else:
+ print "for Double Precision: "
+ if self.device.double_fp_config > 0:
+ for v in ['DENORM', 'INF_NAN', 'FMA',
+ 'ROUND_TO_NEAREST', 'ROUND_TO_ZERO', 'ROUND_TO_INF',
+ 'CORRECTLY_ROUNDED_DIVIDE_SQRT', 'SOFT_FLOAT']:
+ try:
+ if eval('(self.device.double_fp_config &' +
+ ' cl.device_fp_config.' +
+ v + ') == cl.device_fp_config.' + v):
+ print v
+ except AttributeError as ae:
+ if v is 'CORRECTLY_ROUNDED_DIVIDE_SQRT':
+ self.correctlyroundeddividesqrt = False
+ print v, 'is supported in OpenCL C 1.2.\n',
+ print ' Exception catched : ', ae
+ else:
+ raise ValueError("Double Precision is not supported by device")
+ ## Building options and kernel settings
+ build_options = ''
+ if self.correctlyroundeddividesqrt:
+ build_options += " -cl-fp32-correctly-rounded-divide-sqrt "
+ if self.gpu_precision is np.float32:
+ build_options += " -cl-single-precision-constant"
+ build_options += " -D WIDTH=" + str(resolution[0])
+ build_options += " -D WGN=" + str(workItemNumber)
+
+ ## Collect OpenCL source code
+ print "\n Source code:"
+ ## advection
+ if self.advection.include_remesh:
+ if len(resolution) == 3:
+ if self.gpu_precision is np.float32:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh_weights = 'weights_m6prime_opt4_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_3D_opt4_builtin_private4.cl'
+ else:
+ src_remesh_weights = 'weights_m8prime_opt4_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_m8prime_3D_opt4_builtin_private4.cl'
+ else:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh_weights = 'weights_m6prime_opt4_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_3D_opt4_builtin_private4_noBC.cl'
+ else:
+ src_remesh_weights = 'weights_m8prime_opt4_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_m8prime_3D_opt4_builtin_private4_noBC.cl'
+ advec_and_remesh_gwi = (int(workItemNumber), int(resolution[1]), int(resolution[2]))
+ advec_and_remesh_lwi = (int(workItemNumber), 1, 1)
+ else:
+ if self.gpu_precision is np.float32:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh_weights = 'weights_m6prime_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_2D_opt8_builtin_noBC.cl'
+ else:
+ src_remesh_weights = 'weights_m8prime_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_m8prime_2D_opt8_builtin_noBC.cl'
+ else:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh_weights = 'weights_m6prime_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_2D_opt4_builtin_noBC.cl'
+ else:
+ src_remesh_weights = 'weights_m8prime_builtin.cl'
+ src_advec_and_remesh = 'advection_and_remesh_m8prime_2D_opt4_builtin_noBC.cl'
+ advec_and_remesh_gwi = (int(workItemNumber), int(resolution[1]))
+ advec_and_remesh_lwi = (int(workItemNumber), 1)
+ f = open(os.path.join(GPU_SRC, src_remesh_weights))
+ self.gpu_src += "".join(f.readlines())
+ print " - remeshing weights:", f.name
+ f.close()
+ f = open(os.path.join(GPU_SRC, src_advec_and_remesh))
+ print " - advection and remesh:", f.name
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ else:
+ if len(resolution) == 3:
+ if self.gpu_precision is np.float32:
+ src_advec = 'advection_3D_opt4_builtin.cl'
+ else:
+ src_advec = 'advection_3D_opt2_builtin.cl'
+ advec_gwi = (int(workItemNumber), int(resolution[1]), int(resolution[2]))
+ advec_lwi = (int(workItemNumber), 1, 1)
+ else:
+ if self.gpu_precision is np.float32:
+ src_advec = 'advection_2D_opt4_builtin.cl'
+ else:
+ src_advec = 'advection_2D_builtin.cl'
+ advec_gwi = (int(workItemNumber), int(resolution[1]))
+ advec_lwi = (int(workItemNumber), 1)
+ f = open(os.path.join(GPU_SRC, src_advec))
+ print " - advection:", f.name
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ ## remeshing
+ if len(resolution) == 3:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh = 'remeshing_3D_opt4_private4.cl'
+ src_remesh_weights = 'weights_m6prime_opt4_builtin.cl'
+ else:
+ src_remesh = 'remeshing_m8prime_3D_opt4_private4.cl'
+ src_remesh_weights = 'weights_m8prime_opt4_builtin.cl'
+ remesh_gwi = (int(workItemNumber), int(resolution[1]), int(resolution[2]))
+ remesh_lwi = (int(workItemNumber), 1, 1)
+ else:
+ if self.RemeshingMethod is 'm6prime':
+ src_remesh = 'remeshing_2D_opt4_noBC.cl'
+ src_remesh_weights = 'weights_m6prime_builtin.cl'
+ else:
+ src_remesh = 'remeshing_m8prime_2D_opt4_noBC.cl'
+ src_remesh_weights = 'weights_m8prime_builtin.cl'
+ remesh_gwi = (int(workItemNumber), int(resolution[1]))
+ remesh_lwi = (int(workItemNumber), 1)
+ f = open(os.path.join(GPU_SRC, src_remesh_weights))
+ self.gpu_src += "".join(f.readlines())
+ print " - remeshing weights:", f.name
+ f.close()
+ f = open(os.path.join(GPU_SRC, src_remesh))
+ print " - remeshing:", f.name
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ ## copy
+ if len(resolution) == 3:
+ if self.gpu_precision is np.float32:
+ src_copy = 'copy_3D_opt4.cl'
+ build_options += " -D TILE_DIM_COPY=16 -D BLOCK_ROWS_COPY=8"
+ copy_gwi = (int(resolution[0] / 4), int(resolution[1] / 2), int(resolution[2]))
+ copy_lwi = (4, 8, 1)
+ else:
+ src_copy = 'copy_3D_locMem.cl'
+ build_options += " -D TILE_DIM_COPY=32 -D BLOCK_ROWS_COPY=8"
+ copy_gwi = (int(resolution[0]), int(resolution[1] / 4), int(resolution[2]))
+ copy_lwi = (32, 8, 1)
+ else:
+ if self.gpu_precision is np.float32:
+ src_copy = 'copy_2D_opt2.cl'
+ build_options += " -D TILE_DIM_COPY=16 -D BLOCK_ROWS_COPY=8"
+ copy_gwi = (int(resolution[0] / 2), int(resolution[1] / 2))
+ copy_lwi = (8, 8)
+ else:
+ src_copy = 'copy_2D_opt2.cl'
+ build_options += " -D TILE_DIM_COPY=32 -D BLOCK_ROWS_COPY=2"
+ copy_gwi = (int(resolution[0] / 2), int(resolution[1] / 16))
+ copy_lwi = (16, 2)
+ f = open(os.path.join(GPU_SRC, src_copy))
+ print " - copy:", f.name
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ ## transpose
+ if len(resolution) == 3:
+ if self.gpu_precision is np.float32:
+ src_transpose_xy = 'transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt2.cl'
+ build_options += " -D TILE_DIM_XY=16 -D BLOCK_ROWS_XY=8"
+ transpose_xy_gwi = (int(resolution[0] / 2), int(resolution[1] / 2), int(resolution[2]))
+ transpose_xy_lwi = (8, 8, 1)
+ src_transpose_xz = 'transpose_3D_xz_coalesced_locPad_Diag_bis_3DBlock.cl'
+ build_options += " -D TILE_DIM_XZ=16 -D BLOCK_ROWS_XZ=4"
+ transpose_xz_gwi = (int(resolution[0]), int(resolution[1] / 4), int(resolution[2] / 4))
+ transpose_xz_lwi = (16, 4, 4)
+ else:
+ src_transpose_xy = 'transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt4.cl'
+ build_options += " -D TILE_DIM_XY=32 -D BLOCK_ROWS_XY=4"
+ transpose_xy_gwi = (int(resolution[0] / 4), int(resolution[1] / 8), int(resolution[2]))
+ transpose_xy_lwi = (8, 4, 1)
+ src_transpose_xz = 'transpose_3D_xz_coalesced_Diag_bis_3DBlock.cl'
+ build_options += " -D TILE_DIM_XZ=8 -D BLOCK_ROWS_XZ=2"
+ transpose_xz_gwi = (int(resolution[0]), int(resolution[1] / 4), int(resolution[2] / 4))
+ transpose_xz_lwi = (8, 2, 2)
+ else:
+ if self.gpu_precision is np.float32:
+ src_transpose_xy = 'transpose_2D_xy_coalesced_locPad_Diag_opt4.cl'
+ build_options += " -D TILE_DIM_XY=32 -D BLOCK_ROWS_XY=8"
+ transpose_xy_gwi = (int(resolution[0] / 4), int(resolution[1]) / 4)
+ transpose_xy_lwi = (8, 8)
+ else:
+ src_transpose_xy = 'transpose_2D_xy_coalesced_locPad_Diag_opt4.cl'
+ build_options += " -D TILE_DIM_XY=32 -D BLOCK_ROWS_XY=2"
+ transpose_xy_gwi = (int(resolution[0] / 4), int(resolution[1]) / 16)
+ transpose_xy_lwi = (8, 2)
+ f = open(os.path.join(GPU_SRC, src_transpose_xy))
+ print " - transpose_xy:", f.name
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+ if len(resolution) == 3:
+ f = open(os.path.join(GPU_SRC, src_transpose_xz))
+ self.gpu_src += "".join(f.readlines())
+ f.close()
+
+ ## Build code
+ if self.gpu_precision is np.float32:
+ prg = cl.Program(self.ctx, self.gpu_src.replace('.0', '.0f'))
+ else:
+ prg = cl.Program(self.ctx, self.gpu_src.replace('float', 'double'))
+
+ ## OpenCL program
+ self.prg = prg.build(build_options)
+ print "Compiler options : ",
+ print self.prg.get_build_info(self.device, cl.program_build_info.OPTIONS)
+ print "Compiler status : ",
+ print self.prg.get_build_info(self.device, cl.program_build_info.STATUS)
+ print "Compiler log : ",
+ print self.prg.get_build_info(self.device, cl.program_build_info.LOG)
+ print "===\n"
+ # Convert fields to recquired precision (self.gpu_precision) and ensure order
+ for f in self.problem.variables:
+ for df in f.discreteField:
+ if f.vector:
+ for d in xrange(len(df.data)):
+ df.data[d] = np.asarray(df.data[d], dtype=self.gpu_precision, order='F')
+ else:
+ df.data = np.asarray(df.data, dtype=self.gpu_precision, order='F')
+ # Create OpenCL Buffers from fields
+ print "=== OpenCL Buffer allocations ==="
+ total_mem_used = 0
+ for f in self.problem.variables:
+ print f.name, "allocate ",
+ temp_mem_used = 0
+ for df in f.discreteField:
+ if f.vector:
+ for d in xrange(len(df.data)):
+ df.gpu_data[d] = cl.Buffer(self.ctx,
+ cl.mem_flags.READ_WRITE,
+ size=df.data[d].nbytes)
+ temp_mem_used += df.gpu_data[d].size
+ else:
+ df.gpu_data = cl.Buffer(self.ctx,
+ cl.mem_flags.READ_WRITE,
+ size=df.data.nbytes)
+ temp_mem_used += df.gpu_data.size
+ total_mem_used += temp_mem_used
+ print temp_mem_used, "Bytes (", temp_mem_used / (1024 ** 2), "MB)"
+ print "Total Global Memory used : ", total_mem_used, "Bytes (", total_mem_used / (1024 ** 2), "MB)",
+ print "({0:.3f} %)".format(100 * total_mem_used / (self.device.global_mem_size * 1.))
+ print "===\n"
+ print "=== OpenCL Buffer initialisation ==="
+ data, transfer_time, compute_time = 0, 0., 0.
+ for f in self.problem.variables:
+ initKernel = None
+ # Looking for initKernel
+ for k in self.prg.all_kernels():
+ if k.get_info(cl.kernel_info.FUNCTION_NAME) == ('init' + f.name):
+ initKernel = cl.Kernel(self.prg, 'init' + f.name)
+ if initKernel is not None:
+ for df in f.discreteField:
+ print f.name, ": kernel init",
+ global_wg = df.resolution.tolist()
+ if global_wg[0] / workItemNumber > 0:
+ global_wg[0] = workItemNumber
+ if len(global_wg) == 3:
+ local_wg = (workItemNumber, 1, 1)
+ else:
+ local_wg = (workItemNumber, 1)
+ else:
+ local_wg = None
+ global_wg = tuple(global_wg)
+ print global_wg, local_wg,
+ dim = df.topology.dim
+ coord_min = np.ones(4, dtype=self.gpu_precision)
+ mesh_size = np.ones(4, dtype=self.gpu_precision)
+ coord_min[0:dim] = df.topology.mesh.origin
+ mesh_size[0:dim] = df.topology.mesh.size
+ print "...",
+ if f.vector:
+ if dim == 3:
+ evt = initKernel(self.queue,
+ global_wg,
+ local_wg,
+ df.gpu_data[XDIR], df.gpu_data[YDIR], df.gpu_data[ZDIR],
+ coord_min,
+ mesh_size)
+ else:
+ evt = initKernel(self.queue,
+ global_wg,
+ local_wg,
+ df.gpu_data[XDIR], df.gpu_data[YDIR],
+ coord_min,
+ mesh_size)
+ else:
+ evt = initKernel(self.queue,
+ global_wg,
+ local_wg,
+ df.gpu_data,
+ coord_min,
+ mesh_size)
+ self.queue.finish()
+ temp_time = (evt.profile.end - evt.profile.start) * 1e-9
+ print "Done in ", temp_time, "sec"
+ compute_time += temp_time
+ else:
+ for df in f.discreteField:
+ if df.contains_data:
+ print f.name, ":",
+ temp_data, temp_time = hostToDevice(self.queue, df)
+ data += temp_data
+ transfer_time += temp_time
+ if data > 0:
+ print "Total Transfers : ", data, "Bytes transfered at {0:.3f} GBytes/sec".format((data * 1e-9) / transfer_time)
+ if compute_time > 0.:
+ print "Total Computing : ", compute_time, "sec"
+ print "===\n"
+ # Setting advection and remeshing kernels:
+ print "=== OpenCL Kernels setting ==="
+ for op in self.problem.operators:
+ if op.discreteOperator.name == "splitting":
+ for sop in op.operators:
+ print sop.discreteOperator.name,
+ sop.discreteOperator.gpu_precision = self.gpu_precision
+ if sop.discreteOperator.name == 'advection':
+ sop.setMethod(KernelLauncher(self.prg.advection,
+ self.queue,
+ advec_gwi,
+ advec_lwi))
+ elif sop.discreteOperator.name == 'remeshing':
+ sop.setMethod(KernelLauncher(self.prg.remeshing,
+ self.queue,
+ remesh_gwi,
+ remesh_lwi))
+ elif sop.discreteOperator.name == 'advection_and_remeshing':
+ sop.setMethod(KernelLauncher(self.prg.advection_and_remeshing,
+ self.queue,
+ advec_and_remesh_gwi,
+ advec_and_remesh_lwi))
+ else:
+ raise ValueError("Unknown operator : " + sop.discreteOperator.name)
+ else:
+ raise ValueError("Unknown operator : " + op.discreteOperator.name)
+ print self.advection.discreteOperator.name,
+ self.advection.discreteOperator.init_copy = KernelLauncher(self.prg.copy,
+ self.queue,
+ copy_gwi,
+ copy_lwi)
+ if len(resolution) == 3:
+ print self.advection.discreteOperator.name,
+ k = KernelListLauncher([self.prg.transpose_xy,
+ self.prg.transpose_xz],
+ self.queue,
+ [transpose_xy_gwi,
+ transpose_xz_gwi],
+ [transpose_xy_lwi,
+ transpose_xz_lwi])
+ self.advection.discreteOperator.init_transpose = k
+ else:
+ print self.advection.discreteOperator.name,
+ k = KernelLauncher(self.prg.transpose_xy,
+ self.queue,
+ transpose_xy_gwi,
+ transpose_xy_lwi)
+ self.advection.discreteOperator.init_transpose = k
+ self.problem.io.set_get_data_method(self.get_data_from_device)
+ print "===\n"
+
+ def end(self):
+ print "=== OpenCL Buffer deallocations ==="
+ for f in self.problem.variables:
+ print f.name, "deallocate "
+ temp_mem_used = 0
+ for df in f.discreteField:
+ if f.vector:
+ for d in xrange(len(df.data)):
+ if isinstance(df.gpu_data[d], cl.MemoryObject):
+ df.gpu_data[d].release()
+ else:
+ if isinstance(df.gpu_data, cl.MemoryObject):
+ df.gpu_data.release()
+ print "===\n"
+
+ def get_data_from_device(self, field):
+ """Data collect method."""
+ deviceToHost(self.queue, field)
+
+ def __str__(self):
+ """ToString method"""
+ s = " Particular solver "
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : ParticularSolver"
+ print ParticularSolver.__doc__
+
+
+class KernelListLauncher:
+ """
+ OpenCL kernel list launcher.
+
+ Manage launching of OpenCL kernels as a list.
+ """
+ def __init__(self, kernel, queue, gsize=None, lsize=None):
+ """
+ Create a kernel list launcher.
+ @param kernel : kernel list.
+ @param queue : OpenCL command queue.
+ @param gsize : OpenCL global size index.
+ @param lsize : OpenCL local size index.
+ """
+ ## OpenCL Kernel list
+ self.kernel = kernel
+ print [k.function_name for k in self.kernel]
+ ## OpenCL command queue
+ self.queue = queue
+ ## OpenCL global size index.
+ self.global_size = gsize
+ ## OpenCL local size index.
+ self.local_size = lsize
+ self.call_number = [0 for k in self.kernel]
+
+ def launch(self, d, *args):
+ """
+ Launch a kernel.
+
+ @param d : kernel index in kernel list.
+ @param args : kernel arguments.
+ @return OpenCL Event
+
+ OpenCL global size and local sizes are not given in args. Class member are used.
+ """
+ return KernelListLauncher.launch_sizes_in_args(self, d, self.global_size[d], self.local_size[d], *args)
+
+ def launch_sizes_in_args(self, d, *args):
+ """
+ Launch a kernel.
+
+ @param d : kernel index in kernel list.
+ @param args : kernel arguments.
+ @return OpenCL Event.
+
+ Opencl global and local sizes are given in args.
+ """
+ #print self.kernel[d].function_name, args[0], args[1]
+ self.call_number[d] += 1
+ evt = self.kernel[d](self.queue, *args)
+ return evt
+
+ def finish(self):
+ self.queue.finish()
+
+ def function_name(self, d=None):
+ """Prints OpenCL Kernels function names informations"""
+ if d is not None:
+ return self.kernel[d].get_info(cl.kernel_info.FUNCTION_NAME)
+ else:
+ return [k.get_info(cl.kernel_info.FUNCTION_NAME) for k in self.kernel]
+
+
+class KernelLauncher(KernelListLauncher):
+ """
+ OpenCL kernel launcher.
+
+ Manage launching of one OpenCL kernel as a KernelListLauncher with a list of one kernel.
+ """
+ def __init__(self, kernel, queue, gsize, lsize):
+ """
+ Create a KernelLauncher.
+
+ @param kernel : kernel.
+ @param queue : OpenCL command queue.
+ @param gsize : OpenCL global size index.
+ @param lsize : OpenCL local size index.
+
+ Create a KernelListLauncher with a list of one kernel.
+ """
+ KernelListLauncher.__init__(self, [kernel], queue, [gsize], [lsize])
+
+ def launch_sizes_in_args(self, *args):
+ """
+ Launch the kernel.
+
+ @param args : kernel arguments.
+ @return OpenCL Event.
+
+ Opencl global and local sizes are given in args.
+ """
+ return KernelListLauncher.launch_sizes_in_args(self, 0, *args)
+
+ def finish(self):
+ """Wrapping OpenCL queue.finish() method."""
+ self.queue.finish()
+
+ def launch(self, *args):
+ """
+ Launch the kernel.
+
+ @param args : kernel arguments.
+ @return OpenCL Event
+
+ OpenCL global size and local sizes are not given in args. Class member are used.
+ """
+ return KernelListLauncher.launch(self, 0, *args)
+
+ def function_name(self):
+ """Prints OpenCL Kernel function name informations"""
+ res = KernelListLauncher.function_name(self, 0)
+ return res
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src.cl
new file mode 100644
index 0000000000000000000000000000000000000000..af81deb01f79c1eef55f4f61ce169d70e07cb9c0
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src.cl
@@ -0,0 +1,604 @@
+inline float alpha(float y, float s){
+ return (y * (y * (y * (y * (13.0f - 5.0f * y) - 9.0f) - 1.0f) + 2.0f) / 24.0f) * s;}
+inline float beta(float y, float s){
+ return (y * (y * (y * (y * (25.0f * y - 64.0f) + 39.0f) + 16.0f) - 16.0f) / 24.0f)*s;}
+inline float gamma(float y, float s){
+ return (y * y * (y * (y * (126.0f - 50.0f * y) - 70.0f) - 30.0f) / 24.0f + 1.0f)*s;}
+inline float delta(float y, float s){
+ return (y * (y * (y * (y * (50.0f * y - 124.0f) + 66.0f) + 16.0f) + 16.0f) / 24.0f)*s;}
+inline float eta(float y, float s){
+ return (y * (y * (y * (y * (61.0f - 25.0f * y) - 33.0f) - 1.0f) - 2.0f) / 24.0f)*s;}
+inline float zeta(float y, float s){
+ return (y * y * y * (y * (5.0f * y - 12.0f) + 7.0f) / 24.0f)*s;}
+
+#if DIM==3
+__kernel void advection_3D_basic(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int ind, i_ind, i_ind_p;
+ float invdx = 1.0f/dx;
+ uint i;
+ float v, y, p;
+ for(i=gidX; i<WIDTH; i+=NB_WI_ADVECTION)
+ {
+ v = gvelo[i+gidY*WIDTH+gidZ*WIDTH*WIDTH];
+ p = i*dx + 0.5f*dt*v;
+ ind = convert_int_rtn(p * invdx);
+ y = (p - convert_float(ind) * dx) * invdx;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((ind + 1) % WIDTH);
+ p=(gvelo[i_ind+gidY*WIDTH+gidZ*WIDTH*WIDTH]*(1.0f - y) + gvelo[i_ind_p+gidY*WIDTH+gidZ*WIDTH*WIDTH]*y)*dt + i*dx + min_position;
+ ppos[i+gidY*WIDTH+gidZ*WIDTH*WIDTH] = p;
+ }
+}
+__kernel void advection_3D_float4(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int4 ind, i_ind, i_ind_p;
+ float invdx = 1.0f/dx;
+ uint i;
+ float4 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=NB_WI_ADVECTION*4)
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ velocity_cache[i+2] = v.z;
+ velocity_cache[i+3] = v.w;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*4; i<WIDTH; i+=NB_WI_ADVECTION*4)
+ {
+ v = vload4(i/4, velocity_cache);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = coord + 0.5f*dt*v;
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(velocity_cache[i_ind.x], velocity_cache[i_ind.y], velocity_cache[i_ind.z], velocity_cache[i_ind.w]);
+ vp = (float4)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y], velocity_cache[i_ind_p.z], velocity_cache[i_ind_p.w]);
+ p = (v*(1.0f - y) + vp*y)*dt + coord + (float4)(min_position);
+ vstore4(p, (i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, ppos);
+ }
+}
+__kernel void remeshing_3D_float4(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0f/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/NB_WI_REMESHING;
+ float4 p, s, y;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(NB_WI_REMESHING*4))
+{
+ gscal_loc[i] = 0.0f;
+ gscal_loc[i+1] = 0.0f;
+ gscal_loc[i+2] = 0.0f;
+ gscal_loc[i+3] = 0.0f;
+}
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gscal_loc[index4.x] += (alpha(y.x,s.x));
+ gscal_loc[index4.y] += (alpha(y.y,s.y));
+ gscal_loc[index4.z] += (alpha(y.z,s.z));
+ gscal_loc[index4.w] += (alpha(y.w,s.w));
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[index4.x] += (beta(y.x,s.x));
+ gscal_loc[index4.y] += (beta(y.y,s.y));
+ gscal_loc[index4.z] += (beta(y.z,s.z));
+ gscal_loc[index4.w] += (beta(y.w,s.w));
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[index4.x] += (gamma(y.x, s.x));
+ gscal_loc[index4.y] += (gamma(y.y, s.y));
+ gscal_loc[index4.z] += (gamma(y.z, s.z));
+ gscal_loc[index4.w] += (gamma(y.w, s.w));
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[index4.x] += (delta(y.x, s.x));
+ gscal_loc[index4.y] += (delta(y.y, s.y));
+ gscal_loc[index4.z] += (delta(y.z, s.z));
+ gscal_loc[index4.w] += (delta(y.w, s.w));
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[index4.x] += (eta(y.x, s.x));
+ gscal_loc[index4.y] += (eta(y.y, s.y));
+ gscal_loc[index4.z] += (eta(y.z, s.z));
+ gscal_loc[index4.w] += (eta(y.w, s.w));
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[index4.x] += (zeta(y.x, s.x));
+ gscal_loc[index4.y] += (zeta(y.y, s.y));
+ gscal_loc[index4.z] += (zeta(y.z, s.z));
+ gscal_loc[index4.w] += (zeta(y.w, s.w));
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(NB_WI_REMESHING*4))
+ vstore4((float4)(gscal_loc[i],gscal_loc[i+1], gscal_loc[i+2], gscal_loc[i+3]), (i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, gscal);
+}
+
+__kernel void copyLocMem_3D(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = get_group_id(0) * TILE_DIM_COPY_3D + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY_3D + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_COPY_3D][TILE_DIM_COPY_3D];
+
+ for(uint i=0; i<TILE_DIM_COPY_3D; i+=BLOCK_ROWS_COPY_3D)
+ {
+ tile[get_local_id(1)+i][get_local_id(0)] = in[index + i*WIDTH];
+ }
+barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_COPY_3D; i+=BLOCK_ROWS_COPY_3D)
+ {
+ out[index + i*WIDTH] = tile[get_local_id(1)+i][get_local_id(0)];
+ }
+}
+
+__kernel void transpose_3D_xy_coalesced_locPad_Diag(__global const float* in,
+ __global float* out)
+{
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_TRANSPOSE_3D_XY + get_local_id(0);
+ uint yIndex = group_id_y * TILE_DIM_TRANSPOSE_3D_XY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_TRANSPOSE_3D_XY + get_local_id(0);
+ yIndex = group_id_x * TILE_DIM_TRANSPOSE_3D_XY + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_TRANSPOSE_3D_XY][TILE_DIM_TRANSPOSE_3D_XY+1];
+
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_3D_XY; i+=BLOCK_ROWS_TRANSPOSE_3D_XY)
+ {
+ tile[get_local_id(1) + i][get_local_id(0)] = in[index_in + i*WIDTH];
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_3D_XY; i+=BLOCK_ROWS_TRANSPOSE_3D_XY)
+ {
+ out[index_out + i*WIDTH] = tile[get_local_id(0)][get_local_id(1) + i];
+ }
+}
+__kernel void transpose_3D_xz_coalesced(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = get_group_id(0) * TILE_DIM_TRANSPOSE_3D_XZ + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_TRANSPOSE_3D_XZ + get_local_id(1);
+ uint zIndex = get_group_id(2) * TILE_DIM_TRANSPOSE_3D_XZ + get_local_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = get_group_id(2) * TILE_DIM_TRANSPOSE_3D_XZ + get_local_id(0);
+ zIndex = get_group_id(0) * TILE_DIM_TRANSPOSE_3D_XZ + get_local_id(2);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_TRANSPOSE_3D_XZ][TILE_DIM_TRANSPOSE_3D_XZ][TILE_DIM_TRANSPOSE_3D_XZ];
+
+for(uint j=0; j<TILE_DIM_TRANSPOSE_3D_XZ; j+=BLOCK_ROWS_TRANSPOSE_3D_XZ)
+{
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_3D_XZ; i+=BLOCK_ROWS_TRANSPOSE_3D_XZ)
+ {
+ tile[get_local_id(2) + j][get_local_id(1) + i][get_local_id(0)] = in[index_in + i*WIDTH + j*WIDTH*WIDTH];
+ }
+}
+ barrier(CLK_LOCAL_MEM_FENCE);
+for(uint j=0; j<TILE_DIM_TRANSPOSE_3D_XZ; j+=BLOCK_ROWS_TRANSPOSE_3D_XZ)
+{
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_3D_XZ; i+=BLOCK_ROWS_TRANSPOSE_3D_XZ)
+ {
+ out[index_out + i*WIDTH + j*WIDTH*WIDTH] = tile[get_local_id(0)][get_local_id(1)+i][get_local_id(2) + j];
+ }
+}
+}
+#else
+__kernel void advection_2D_float4(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int4 ind, i_ind, i_ind_p;
+ float invdx = 1.0f/dx;
+ uint i;
+ float4 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=NB_WI_ADVECTION*4)
+ {
+ v = vload4((i+gidY*WIDTH)/4, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ velocity_cache[i+2] = v.z;
+ velocity_cache[i+3] = v.w;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*4; i<WIDTH; i+=NB_WI_ADVECTION*4)
+ {
+ v = vload4(i/4, velocity_cache);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = coord + 0.5f*dt*v;
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(velocity_cache[i_ind.x], velocity_cache[i_ind.y], velocity_cache[i_ind.z], velocity_cache[i_ind.w]);
+ vp = (float4)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y], velocity_cache[i_ind_p.z], velocity_cache[i_ind_p.w]);
+ p = (v*(1.0f - y) + vp*y)*dt + coord + (float4)(min_position);
+ vstore4(p, (i+gidY*WIDTH)/4, ppos);
+ }
+}
+
+__kernel void advection_2D_basic(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int ind, i_ind, i_ind_p;
+ float invdx = 1.0f/dx;
+ uint i;
+ float v, y, p;
+ for(i=gidX; i<WIDTH; i+=NB_WI_ADVECTION)
+ {
+ v = gvelo[i+gidY*WIDTH];
+ p = i*dx + 0.5f*dt*v;
+ ind = convert_int_rtn(p * invdx);
+ y = (p - convert_float(ind) * dx) * invdx;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((ind + 1) % WIDTH);
+ p=(gvelo[i_ind+gidY*WIDTH]*(1.0f - y) + gvelo[i_ind_p+gidY*WIDTH]*y)*dt + i*dx + min_position;
+ ppos[i+gidY*WIDTH] = p;
+ }
+}
+
+
+__kernel void remeshing_2D_float4(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0f/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/NB_WI_REMESHING;
+ float4 p, s, y;
+ float gsx, gsy, gsz, gsw;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(NB_WI_REMESHING*4))
+{
+ gscal_loc[i] = 0.0f;
+ gscal_loc[i+1] = 0.0f;
+ gscal_loc[i+2] = 0.0f;
+ gscal_loc[i+3] = 0.0f;
+}
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (alpha(y.x, s.x));
+ gsy = gsy + (alpha(y.y, s.y));
+ gsz = gsz + (alpha(y.z, s.z));
+ gsw = gsw + (alpha(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (beta(y.x, s.x));
+ gsy = gsy + (beta(y.y, s.y));
+ gsz = gsz + (beta(y.z, s.z));
+ gsw = gsw + (beta(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (gamma(y.x, s.x));
+ gsy = gsy + (gamma(y.y, s.y));
+ gsz = gsz + (gamma(y.z, s.z));
+ gsw = gsw + (gamma(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (delta(y.x, s.x));
+ gsy = gsy + (delta(y.y, s.y));
+ gsz = gsz + (delta(y.z, s.z));
+ gsw = gsw + (delta(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (eta(y.x, s.x));
+ gsy = gsy + (eta(y.y, s.y));
+ gsz = gsz + (eta(y.z, s.z));
+ gsw = gsw + (eta(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gsx = gscal_loc[index4.x];
+ gsy = gscal_loc[index4.y];
+ gsz = gscal_loc[index4.z];
+ gsw = gscal_loc[index4.w];
+ gsx = gsx + (zeta(y.x, s.x));
+ gsy = gsy + (zeta(y.y, s.y));
+ gsz = gsz + (zeta(y.z, s.z));
+ gsw = gsw + (zeta(y.w, s.w));
+ gscal_loc[index4.x] = gsx;
+ gscal_loc[index4.y] = gsy;
+ gscal_loc[index4.z] = gsz;
+ gscal_loc[index4.w] = gsw;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(NB_WI_REMESHING*4))
+ vstore4((float4)(gscal_loc[i],gscal_loc[i+1], gscal_loc[i+2], gscal_loc[i+3]), (i + gidY*WIDTH)/4, gscal);
+}
+
+__kernel void copyLocMem_2D(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = get_group_id(0) * TILE_DIM_COPY_2D + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY_2D + get_local_id(1);
+ uint index = xIndex + yIndex * WIDTH;
+
+ __local float tile[TILE_DIM_COPY_2D][TILE_DIM_COPY_2D];
+
+ for(uint i=0; i<TILE_DIM_COPY_2D; i+=BLOCK_ROWS_COPY_2D)
+ {
+ tile[get_local_id(1)+i][get_local_id(0)] = in[index + i*WIDTH];
+ }
+barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_COPY_2D; i+=BLOCK_ROWS_COPY_2D)
+ {
+ out[index + i*WIDTH] = tile[get_local_id(1)+i][get_local_id(0)];
+ }
+}
+
+__kernel void transpose_2D_coalesced_locPad_Diag(__global const float* in,
+ __global float* out)
+{
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_TRANSPOSE_2D + get_local_id(0);
+ uint yIndex = group_id_y * TILE_DIM_TRANSPOSE_2D + get_local_id(1);
+ uint index_in = xIndex + yIndex * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_TRANSPOSE_2D + get_local_id(0);
+ yIndex = group_id_x * TILE_DIM_TRANSPOSE_2D + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH;
+
+ __local float tile[TILE_DIM_TRANSPOSE_2D][TILE_DIM_TRANSPOSE_2D+1];
+
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_2D; i+=BLOCK_ROWS_TRANSPOSE_2D)
+ {
+ tile[get_local_id(1) + i][get_local_id(0)] = in[index_in + i*WIDTH];
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_TRANSPOSE_2D; i+=BLOCK_ROWS_TRANSPOSE_2D)
+ {
+ out[index_out + i*WIDTH] = tile[get_local_id(0)][get_local_id(1) + i];
+ }
+}
+
+
+#endif
+
+
+
+
+
+
+
+
+
+
+
+
+/*
+
+// volume computing
+__kernel void volume(__global const float* pscal,
+ __global float* volume,
+ __private const float level,
+ __private const float particle_volume,
+ __private const int dir,
+ __private const uint line_nb_pts,
+ __private const float4 min_v,
+ __private const float4 max_v,
+ __private const uint4 nb,
+ __private const float4 size
+ )
+{
+ __private uint p; // Particle line loop index
+ __private uint stride_along_dir, stride_along_dir_scal; // Buffer stride between two particle of the same line
+ __private uint ind_line, ind_line_scal; // Line begin buffer index
+ __private float dx_dir; // Space step along line
+ __private float pscal_c; // Particle scalar along line
+ // Compute strides and index. Depend on array order (C order here)
+ dx_dir = size[dir];
+
+ if(DIM == 3){
+ if (dir == 0)
+ {
+ kernel_init_3_0(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ }
+ else if (dir == 1)
+ {
+ kernel_init_3_1(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ }
+ else
+ {
+ kernel_init_3_2(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ }}
+ else{
+ if (dir == 0)
+ {
+ kernel_init_2_0(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ }
+ else
+ {
+ kernel_init_2_1(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ }
+ }
+
+ volume[ind_line_scal]= 0.0f;
+ for(p=0;p<line_nb_pts;p++)
+ {
+ // read particle scalar
+ pscal_c = pscal[ind_line_scal + p*stride_along_dir_scal]; // Read : 1float
+ if (pscal_c > level)
+ volume[ind_line_scal] += particle_volume;
+ }
+}
+
+
+
+
+// Colorize scalar
+__kernel void colorize(__global const float* pscal,
+ __global float* pcolor,
+ __global float* points,
+ __private const uint dir,
+ __private const uint line_nb_pts,
+ __private const float4 min,
+ __private const uint4 nb,
+ __private const float4 size
+ )
+{
+ __private uint p;
+ __private float color, dx_dir;
+ __private size_t stride_vec;
+ __private uint stride_along_dir, stride_along_dir_scal;
+ __private uint ind_line, ind_line_scal;
+ __private float line_c[DIM];
+ stride_vec = 1; // Les composantes des vecteurs sont à la suite dans les buffers
+ dx_dir = size[dir];
+ if(DIM == 3)
+ {
+ if (dir == 0)
+ {
+ kernel_init_3_0(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ advection_init_3_0(size, line_c);
+ }
+ else if (dir == 1)
+ {
+ kernel_init_3_1(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ advection_init_3_1(size, line_c);
+ }
+ else
+ {
+ kernel_init_3_2(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ advection_init_3_2(size, line_c);
+ }
+ }
+ else
+ {
+ if (dir == 0)
+ {
+ kernel_init_2_0(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ advection_init_2_0(size, line_c);
+ }
+ else
+ {
+ kernel_init_2_1(nb, &stride_along_dir, &stride_along_dir_scal, &ind_line, &ind_line_scal);
+ advection_init_2_1(size, line_c);
+ }
+ }
+
+ for(p=0;p<line_nb_pts;p++)
+ {
+ // Write result in buffer
+ line_c[dir] = p*dx_dir;
+ points[ind_line + p*stride_along_dir] = min.s0 + line_c[0];
+ points[ind_line + stride_vec + p*stride_along_dir] = min.s1 + line_c[1];
+#if DIM == 3
+ points[ind_line + 2*stride_vec + p*stride_along_dir] = min.s2 + line_c[2];
+#else
+ points[ind_line + 2*stride_vec + p*stride_along_dir] = 0.0f;
+#endif
+ color = pscal[ind_line_scal + p*stride_along_dir_scal];
+ if (color > 0.5){
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal] = 1.0f; //Red
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal + 3] = 1.0f; //Alpha
+ }
+ else{
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal] = 1.0f; //Red
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal + 3] = 0.0f; //Alpha
+ }
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal + 1] = 0.0f; //Green
+ pcolor[4*ind_line_scal + 4*p*stride_along_dir_scal + 2] = 0.0f; //Blue
+ }
+
+}
+*/
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..008be61a924d04004e424cf66c0dadd509ac59c2
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_builtin.cl
@@ -0,0 +1,34 @@
+/**
+ * 2D advection kernel.
+ *
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float v, y, p;
+ for(i=gidX; i<WIDTH; i+=WGN)
+ {
+ v = gvelo[i+gidY*WIDTH];
+ p = fma((float)(0.5*dt),v,i*dx);
+ ind = convert_int_rtn(p * invdx);
+ y = (fma(- convert_float(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((ind + 1) % WIDTH);
+ p=fma(mix(gvelo[i_ind+gidY*WIDTH],gvelo[i_ind_p+gidY*WIDTH],y),dt,i*dx + min_position);
+ ppos[i+gidY*WIDTH] = p;
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt2_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt2_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..d99fe53429fe274cca78682038c06150eda981b9
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt2_builtin.cl
@@ -0,0 +1,49 @@
+/**
+ * 2D advection kernel.
+ *
+ * Memory reads and writes are performed using 2 element OpenCL vectors (float2 or double2).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int2 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float2 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*2; i<WIDTH; i+=WGN*2)
+ {
+ v = vload2((i+gidY*WIDTH)/2, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*2; i<WIDTH; i+=WGN*2)
+ {
+ v = vload2(i/2, velocity_cache);
+ coord = (float2)(i*dx, (i+1)*dx);
+ p = fma((float2)(0.5*dt),v,coord);
+ ind = convert_int2_rtn(p * invdx);
+ y = (fma(- convert_float2(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float2)(velocity_cache[i_ind.x], velocity_cache[i_ind.y]);
+ vp = (float2)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y]);
+ p=fma(mix(v,vp,y),dt,coord + (float2)(min_position));
+ vstore2(p, (i+gidY*WIDTH)/2, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt4_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt4_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..c9d9637ad6728e8b5346532d706618100e647324
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt4_builtin.cl
@@ -0,0 +1,53 @@
+/**
+ * 2D advection kernel.
+ *
+ * Memory reads and writes are performed using 4 element OpenCL vectors (float4 or double4).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int4 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float4 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=WGN*4)
+ {
+ v = vload4((i+gidY*WIDTH)/4, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ velocity_cache[i+2] = v.z;
+ velocity_cache[i+3] = v.w;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*4; i<WIDTH; i+=WGN*4)
+ {
+ v = vload4(i/4, velocity_cache);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(velocity_cache[i_ind.x], velocity_cache[i_ind.y],
+ velocity_cache[i_ind.z], velocity_cache[i_ind.w]);
+ vp = (float4)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y],
+ velocity_cache[i_ind_p.z], velocity_cache[i_ind_p.w]);
+ p=fma(mix(v,vp,y),dt,coord + (float4)(min_position));
+ vstore4(p, (i+gidY*WIDTH)/4, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt8_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt8_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..cab7c1dd42d87d26fb21c864a80211d430d2a460
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_2D_opt8_builtin.cl
@@ -0,0 +1,76 @@
+/**
+ * 2D advection kernel.
+ *
+ * Memory reads and writes are performed using 8 element OpenCL vectors (float8 or double8).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ int8 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float8 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*8; i<WIDTH; i+=WGN*8)
+ {
+ v = vload8((i+gidY*WIDTH)/8, gvelo);
+ velocity_cache[i] = v.s0;
+ velocity_cache[i+1] = v.s1;
+ velocity_cache[i+2] = v.s2;
+ velocity_cache[i+3] = v.s3;
+ velocity_cache[i+4] = v.s4;
+ velocity_cache[i+5] = v.s5;
+ velocity_cache[i+6] = v.s6;
+ velocity_cache[i+7] = v.s7;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*8; i<WIDTH; i+=WGN*8)
+ {
+ v = vload8(i/8, velocity_cache);
+ coord = (float8)(i*dx,
+ (i+1)*dx,
+ (i+2)*dx,
+ (i+3)*dx,
+ (i+4)*dx,
+ (i+5)*dx,
+ (i+6)*dx,
+ (i+7)*dx);
+ p = fma((float8)(0.5*dt),v,coord);
+ ind = convert_int8_rtn(p * invdx);
+ y = (fma(- convert_float8(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float8)(velocity_cache[i_ind.s0],
+ velocity_cache[i_ind.s1],
+ velocity_cache[i_ind.s2],
+ velocity_cache[i_ind.s3],
+ velocity_cache[i_ind.s4],
+ velocity_cache[i_ind.s5],
+ velocity_cache[i_ind.s6],
+ velocity_cache[i_ind.s7]);
+ vp = (float8)(velocity_cache[i_ind_p.s0],
+ velocity_cache[i_ind_p.s1],
+ velocity_cache[i_ind_p.s2],
+ velocity_cache[i_ind_p.s3],
+ velocity_cache[i_ind_p.s4],
+ velocity_cache[i_ind_p.s5],
+ velocity_cache[i_ind_p.s6],
+ velocity_cache[i_ind_p.s7]);
+ p = fma(mix(v,vp,y),dt,coord + (float8)(min_position));
+ vstore8(p, (i+gidY*WIDTH)/8, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..c54dd72679192fcca254c170d8669d3cbe80742f
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_builtin.cl
@@ -0,0 +1,37 @@
+/**
+ * 3D advection kernel.
+ *
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float v, y, p;
+ for(i=gidX; i<WIDTH; i+=WGN)
+ {
+ v = gvelo[i+gidY*WIDTH+gidZ*WIDTH*WIDTH];
+ p = fma((float)(0.5*dt),v,i*dx);
+ ind = convert_int_rtn(p * invdx);
+ y = (fma(- convert_float(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((ind + 1) % WIDTH);
+ p=fma(mix(gvelo[i_ind+gidY*WIDTH+gidZ*WIDTH*WIDTH],
+ gvelo[i_ind_p+gidY*WIDTH+gidZ*WIDTH*WIDTH],y),
+ dt,i*dx + min_position);
+ ppos[i+gidY*WIDTH+gidZ*WIDTH*WIDTH] = p;
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt2_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt2_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..3891bb10dcdc5442cb14e4857f385eb4f4c7f4c8
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt2_builtin.cl
@@ -0,0 +1,50 @@
+/**
+ * 3D advection kernel.
+ *
+ * Memory reads and writes are performed using 2 element OpenCL vectors (float2 or double2).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int2 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float2 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*2; i<WIDTH; i+=WGN*2)
+ {
+ v = vload2((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/2, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*2; i<WIDTH; i+=WGN*2)
+ {
+ v = vload2(i/2, velocity_cache);
+ coord = (float2)(i*dx, (i+1)*dx);
+ p = fma((float2)(0.5*dt),v,coord);
+ ind = convert_int2_rtn(p * invdx);
+ y = (fma(- convert_float2(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float2)(velocity_cache[i_ind.x], velocity_cache[i_ind.y]);
+ vp = (float2)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y]);
+ p=fma(mix(v,vp,y),dt,coord + (float2)(min_position));
+ vstore2(p, (i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/2, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt4_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt4_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..49ae8e1d4bb4ab796e0b659eaeadc7e8177bb0eb
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt4_builtin.cl
@@ -0,0 +1,54 @@
+/**
+ * 3D advection kernel.
+ *
+ * Memory reads and writes are performed using 4 element OpenCL vectors (float4 or double4).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int4 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float4 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=WGN*4)
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ velocity_cache[i] = v.x;
+ velocity_cache[i+1] = v.y;
+ velocity_cache[i+2] = v.z;
+ velocity_cache[i+3] = v.w;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*4; i<WIDTH; i+=WGN*4)
+ {
+ v = vload4(i/4, velocity_cache);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(velocity_cache[i_ind.x], velocity_cache[i_ind.y],
+ velocity_cache[i_ind.z], velocity_cache[i_ind.w]);
+ vp = (float4)(velocity_cache[i_ind_p.x], velocity_cache[i_ind_p.y],
+ velocity_cache[i_ind_p.z], velocity_cache[i_ind_p.w]);
+ p=fma(mix(v,vp,y),dt,coord + (float4)(min_position));
+ vstore4(p, (i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt8_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt8_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..db3fb09a765970c6a15b7c3f43a99fc3e92c46bb
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_3D_opt8_builtin.cl
@@ -0,0 +1,77 @@
+/**
+ * 3D advection kernel.
+ *
+ * Memory reads and writes are performed using 8 element OpenCL vectors (float8 or double8).
+ * Computations are done using builtin functions on vector types.
+ * A local array is used un local memory as a cache for velocity.
+ *
+ * @param gvelo Velocity.
+ * @param ppos Particle position.
+ * @param dt Time step.
+ * @param min_position Domain lower point.
+ * @param dx Space step.
+ */
+__kernel void advection(__global const float* gvelo,
+ __global float* ppos,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ int8 ind, i_ind, i_ind_p;
+ float invdx = 1.0/dx;
+ uint i;
+ float8 v, vp, y, p, coord;
+ __local float velocity_cache[WIDTH];
+
+ for(i=gidX*8; i<WIDTH; i+=WGN*8)
+ {
+ v = vload8((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/8, gvelo);
+ velocity_cache[i] = v.s0;
+ velocity_cache[i+1] = v.s1;
+ velocity_cache[i+2] = v.s2;
+ velocity_cache[i+3] = v.s3;
+ velocity_cache[i+4] = v.s4;
+ velocity_cache[i+5] = v.s5;
+ velocity_cache[i+6] = v.s6;
+ velocity_cache[i+7] = v.s7;
+ }
+
+ barrier(CLK_LOCAL_MEM_FENCE);
+
+ for(i=gidX*8; i<WIDTH; i+=WGN*8)
+ {
+ v = vload8(i/8, velocity_cache);
+ coord = (float8)(i*dx,
+ (i+1)*dx,
+ (i+2)*dx,
+ (i+3)*dx,
+ (i+4)*dx,
+ (i+5)*dx,
+ (i+6)*dx,
+ (i+7)*dx);
+ p = fma((float8)(0.5*dt),v,coord);
+ ind = convert_int8_rtn(p * invdx);
+ y = (fma(- convert_float8(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float8)(velocity_cache[i_ind.s0],
+ velocity_cache[i_ind.s1],
+ velocity_cache[i_ind.s2],
+ velocity_cache[i_ind.s3],
+ velocity_cache[i_ind.s4],
+ velocity_cache[i_ind.s5],
+ velocity_cache[i_ind.s6],
+ velocity_cache[i_ind.s7]);
+ vp = (float8)(velocity_cache[i_ind_p.s0],
+ velocity_cache[i_ind_p.s1],
+ velocity_cache[i_ind_p.s2],
+ velocity_cache[i_ind_p.s3],
+ velocity_cache[i_ind_p.s4],
+ velocity_cache[i_ind_p.s5],
+ velocity_cache[i_ind_p.s6],
+ velocity_cache[i_ind_p.s7]);
+ p = fma(mix(v,vp,y),dt,coord + (float8)(min_position));
+ vstore8(p, (i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/8, ppos);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt4_builtin_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt4_builtin_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..2eaec614a26d971b549d417d48d85a2ce4f5dd80
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt4_builtin_noBC.cl
@@ -0,0 +1,95 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH)/4, gvelo);
+ gvelo_loc[noBC_id(i,nb_part)] = v.x;
+ gvelo_loc[noBC_id(i+1,nb_part)] = v.y;
+ gvelo_loc[noBC_id(i+2,nb_part)] = v.z;
+ gvelo_loc[noBC_id(i+3,nb_part)] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = (float4)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)]);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[noBC_id(i_ind.x,nb_part)], gvelo_loc[noBC_id(i_ind.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind.z,nb_part)], gvelo_loc[noBC_id(i_ind.w,nb_part)]);
+ vp = (float4)(gvelo_loc[noBC_id(i_ind_p.x,nb_part)], gvelo_loc[noBC_id(i_ind_p.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.z,nb_part)], gvelo_loc[noBC_id(i_ind_p.w,nb_part)]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gscal_loc[noBC_id(index4.x,nb_part)] += (alpha(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (alpha(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (alpha(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (alpha(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (beta(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (beta(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (beta(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (beta(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (gamma(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (gamma(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (gamma(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (gamma(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (delta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (delta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (delta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (delta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (eta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (eta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (eta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (eta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (zeta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (zeta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (zeta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (zeta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i,nb_part)],gscal_loc[noBC_id(i+1,nb_part)], gscal_loc[noBC_id(i+2,nb_part)], gscal_loc[noBC_id(i+3,nb_part)]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt8_builtin_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt8_builtin_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..289b9d4a6a0c4fc9bd2f84c09e96d294385485ed
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_2D_opt8_builtin_noBC.cl
@@ -0,0 +1,157 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt,float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int8 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float8 p, s, y, gs, v, vp, coord;
+ uint8 index8;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*8; i<WIDTH; i+=(WGN*8))
+ {
+ v = vload8((i+gidY*WIDTH)/8, gvelo);
+ gvelo_loc[noBC_id(i,nb_part)] = v.s0;
+ gvelo_loc[noBC_id(i+1,nb_part)] = v.s1;
+ gvelo_loc[noBC_id(i+2,nb_part)] = v.s2;
+ gvelo_loc[noBC_id(i+3,nb_part)] = v.s3;
+ gvelo_loc[noBC_id(i+4,nb_part)] = v.s4;
+ gvelo_loc[noBC_id(i+5,nb_part)] = v.s5;
+ gvelo_loc[noBC_id(i+6,nb_part)] = v.s6;
+ gvelo_loc[noBC_id(i+7,nb_part)] = v.s7;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ gscal_loc[i+4] = 0.0;
+ gscal_loc[i+5] = 0.0;
+ gscal_loc[i+6] = 0.0;
+ gscal_loc[i+7] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=8)
+ {
+ v = (float8)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)],
+ gvelo_loc[noBC_id(i+4,nb_part)],
+ gvelo_loc[noBC_id(i+5,nb_part)],
+ gvelo_loc[noBC_id(i+6,nb_part)],
+ gvelo_loc[noBC_id(i+7,nb_part)]);
+ coord = (float8)(i*dx,
+ (i+1)*dx,
+ (i+2)*dx,
+ (i+3)*dx,
+ (i+4)*dx,
+ (i+5)*dx,
+ (i+6)*dx,
+ (i+7)*dx);
+ p = fma((float8)(0.5*dt),v,coord);
+ ind = convert_int8_rtn(p * invdx);
+ y = (fma(- convert_float8(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float8)(gvelo_loc[noBC_id(i_ind.s0,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s1,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s2,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s3,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s4,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s5,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s6,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s7,nb_part)]);
+ vp = (float8)(gvelo_loc[noBC_id(i_ind_p.s0,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s1,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s2,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s3,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s4,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s5,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s6,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s7,nb_part)]);
+ p = fma(mix(v,vp,y),dt,coord);
+
+ s = vload8((i + gidY*WIDTH)/8, pscal);
+ ind = convert_int8_rtn(p * invdx);
+ y = (p - convert_float8(ind) * dx) * invdx;
+ index8 = convert_uint8((ind - 2 + WIDTH) % WIDTH);
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (alpha(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (alpha(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (alpha(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (alpha(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (alpha(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (alpha(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (alpha(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (alpha(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (beta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (beta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (beta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (beta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (beta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (beta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (beta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (beta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (gamma(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (gamma(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (gamma(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (gamma(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (gamma(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (gamma(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (gamma(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (gamma(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (delta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (delta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (delta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (delta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (delta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (delta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (delta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (delta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (eta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (eta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (eta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (eta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (eta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (eta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (eta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (eta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (zeta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (zeta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (zeta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (zeta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (zeta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (zeta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (zeta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (zeta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*8; i<WIDTH; i+=(WGN*8))
+ vstore8((float8)(gscal_loc[noBC_id(i,nb_part)],
+ gscal_loc[noBC_id(i+1,nb_part)],
+ gscal_loc[noBC_id(i+2,nb_part)],
+ gscal_loc[noBC_id(i+3,nb_part)],
+ gscal_loc[noBC_id(i+4,nb_part)],
+ gscal_loc[noBC_id(i+5,nb_part)],
+ gscal_loc[noBC_id(i+6,nb_part)],
+ gscal_loc[noBC_id(i+7,nb_part)]), (i + gidY*WIDTH)/8, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..46e9bc59b2ea793d24cd36c429a41bb0e448ff8e
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4.cl
@@ -0,0 +1,101 @@
+
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ gvelo_loc[i] = v.x;
+ gvelo_loc[i+1] = v.y;
+ gvelo_loc[i+2] = v.z;
+ gvelo_loc[i+3] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = vload4(i/4, gvelo_loc);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[i_ind.x], gvelo_loc[i_ind.y],
+ gvelo_loc[i_ind.z], gvelo_loc[i_ind.w]);
+ vp = (float4)(gvelo_loc[i_ind_p.x], gvelo_loc[i_ind_p.y],
+ gvelo_loc[i_ind_p.z], gvelo_loc[i_ind_p.w]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (alpha(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (beta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (gamma(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (delta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (eta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (zeta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[i],gscal_loc[i+1], gscal_loc[i+2], gscal_loc[i+3]), (i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..5d221f67393d24f1f7614f422ef0396ad22d8c20
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_3D_opt4_builtin_private4_noBC.cl
@@ -0,0 +1,101 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ gvelo_loc[noBC_id(i, nb_part)] = v.x;
+ gvelo_loc[noBC_id(i+1, nb_part)] = v.y;
+ gvelo_loc[noBC_id(i+2, nb_part)] = v.z;
+ gvelo_loc[noBC_id(i+3, nb_part)] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = (float4)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)]);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[noBC_id(i_ind.x,nb_part)], gvelo_loc[noBC_id(i_ind.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind.z,nb_part)], gvelo_loc[noBC_id(i_ind.w,nb_part)]);
+ vp = (float4)(gvelo_loc[noBC_id(i_ind_p.x,nb_part)], gvelo_loc[noBC_id(i_ind_p.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.z,nb_part)], gvelo_loc[noBC_id(i_ind_p.w,nb_part)]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i, nb_part)],gscal_loc[noBC_id(i+1, nb_part)], gscal_loc[noBC_id(i+2, nb_part)], gscal_loc[noBC_id(i+3, nb_part)]), (i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt4_builtin_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt4_builtin_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..0a52ced9c1e2b91c9fafd7e2112570f257dae76a
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt4_builtin_noBC.cl
@@ -0,0 +1,107 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH)/4, gvelo);
+ gvelo_loc[noBC_id(i,nb_part)] = v.x;
+ gvelo_loc[noBC_id(i+1,nb_part)] = v.y;
+ gvelo_loc[noBC_id(i+2,nb_part)] = v.z;
+ gvelo_loc[noBC_id(i+3,nb_part)] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = (float4)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)]);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[noBC_id(i_ind.x,nb_part)], gvelo_loc[noBC_id(i_ind.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind.z,nb_part)], gvelo_loc[noBC_id(i_ind.w,nb_part)]);
+ vp = (float4)(gvelo_loc[noBC_id(i_ind_p.x,nb_part)], gvelo_loc[noBC_id(i_ind_p.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.z,nb_part)], gvelo_loc[noBC_id(i_ind_p.w,nb_part)]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 3 + WIDTH) % WIDTH);
+ gscal_loc[noBC_id(index4.x,nb_part)] += (alpha(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (alpha(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (alpha(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (alpha(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (beta(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (beta(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (beta(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (beta(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (gamma(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (gamma(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (gamma(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (gamma(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (delta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (delta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (delta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (delta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (eta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (eta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (eta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (eta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (zeta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (zeta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (zeta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (zeta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (theta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (theta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (theta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (theta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (iota(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (iota(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (iota(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (iota(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i,nb_part)],gscal_loc[noBC_id(i+1,nb_part)], gscal_loc[noBC_id(i+2,nb_part)], gscal_loc[noBC_id(i+3,nb_part)]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt8_builtin_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt8_builtin_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..043ba841f8340cbb165a100c2b6b114d6b85afd4
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_2D_opt8_builtin_noBC.cl
@@ -0,0 +1,177 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt,float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int8 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float8 p, s, y, gs, v, vp, coord;
+ uint8 index8;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*8; i<WIDTH; i+=(WGN*8))
+ {
+ v = vload8((i+gidY*WIDTH)/8, gvelo);
+ gvelo_loc[noBC_id(i,nb_part)] = v.s0;
+ gvelo_loc[noBC_id(i+1,nb_part)] = v.s1;
+ gvelo_loc[noBC_id(i+2,nb_part)] = v.s2;
+ gvelo_loc[noBC_id(i+3,nb_part)] = v.s3;
+ gvelo_loc[noBC_id(i+4,nb_part)] = v.s4;
+ gvelo_loc[noBC_id(i+5,nb_part)] = v.s5;
+ gvelo_loc[noBC_id(i+6,nb_part)] = v.s6;
+ gvelo_loc[noBC_id(i+7,nb_part)] = v.s7;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ gscal_loc[i+4] = 0.0;
+ gscal_loc[i+5] = 0.0;
+ gscal_loc[i+6] = 0.0;
+ gscal_loc[i+7] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=8)
+ {
+ v = (float8)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)],
+ gvelo_loc[noBC_id(i+4,nb_part)],
+ gvelo_loc[noBC_id(i+5,nb_part)],
+ gvelo_loc[noBC_id(i+6,nb_part)],
+ gvelo_loc[noBC_id(i+7,nb_part)]);
+ coord = (float8)(i*dx,
+ (i+1)*dx,
+ (i+2)*dx,
+ (i+3)*dx,
+ (i+4)*dx,
+ (i+5)*dx,
+ (i+6)*dx,
+ (i+7)*dx);
+ p = fma((float8)(0.5*dt),v,coord);
+ ind = convert_int8_rtn(p * invdx);
+ y = (fma(- convert_float8(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float8)(gvelo_loc[noBC_id(i_ind.s0,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s1,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s2,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s3,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s4,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s5,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s6,nb_part)],
+ gvelo_loc[noBC_id(i_ind.s7,nb_part)]);
+ vp = (float8)(gvelo_loc[noBC_id(i_ind_p.s0,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s1,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s2,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s3,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s4,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s5,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s6,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.s7,nb_part)]);
+ p = fma(mix(v,vp,y),dt,coord);
+
+ s = vload8((i + gidY*WIDTH)/8, pscal);
+ ind = convert_int8_rtn(p * invdx);
+ y = (p - convert_float8(ind) * dx) * invdx;
+ index8 = convert_uint8((ind - 3 + WIDTH) % WIDTH);
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (alpha(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (alpha(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (alpha(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (alpha(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (alpha(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (alpha(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (alpha(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (alpha(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (beta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (beta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (beta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (beta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (beta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (beta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (beta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (beta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (gamma(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (gamma(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (gamma(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (gamma(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (gamma(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (gamma(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (gamma(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (gamma(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (delta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (delta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (delta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (delta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (delta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (delta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (delta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (delta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (eta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (eta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (eta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (eta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (eta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (eta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (eta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (eta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (zeta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (zeta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (zeta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (zeta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (zeta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (zeta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (zeta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (zeta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (theta(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (theta(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (theta(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (theta(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (theta(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (theta(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (theta(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (theta(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index8 = (index8 + 1) % WIDTH;
+ gscal_loc[noBC_id(index8.s0,nb_part)] += (iota(y.s0,s.s0));
+ gscal_loc[noBC_id(index8.s1,nb_part)] += (iota(y.s1,s.s1));
+ gscal_loc[noBC_id(index8.s2,nb_part)] += (iota(y.s2,s.s2));
+ gscal_loc[noBC_id(index8.s3,nb_part)] += (iota(y.s3,s.s3));
+ gscal_loc[noBC_id(index8.s4,nb_part)] += (iota(y.s4,s.s4));
+ gscal_loc[noBC_id(index8.s5,nb_part)] += (iota(y.s5,s.s5));
+ gscal_loc[noBC_id(index8.s6,nb_part)] += (iota(y.s6,s.s6));
+ gscal_loc[noBC_id(index8.s7,nb_part)] += (iota(y.s7,s.s7));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*8; i<WIDTH; i+=(WGN*8))
+ vstore8((float8)(gscal_loc[noBC_id(i,nb_part)],
+ gscal_loc[noBC_id(i+1,nb_part)],
+ gscal_loc[noBC_id(i+2,nb_part)],
+ gscal_loc[noBC_id(i+3,nb_part)],
+ gscal_loc[noBC_id(i+4,nb_part)],
+ gscal_loc[noBC_id(i+5,nb_part)],
+ gscal_loc[noBC_id(i+6,nb_part)],
+ gscal_loc[noBC_id(i+7,nb_part)]), (i + gidY*WIDTH)/8, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..92b5088204f252db33ca302dc038cbe71bc54111
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4.cl
@@ -0,0 +1,115 @@
+
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ gvelo_loc[i] = v.x;
+ gvelo_loc[i+1] = v.y;
+ gvelo_loc[i+2] = v.z;
+ gvelo_loc[i+3] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = vload4(i/4, gvelo_loc);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[i_ind.x], gvelo_loc[i_ind.y],
+ gvelo_loc[i_ind.z], gvelo_loc[i_ind.w]);
+ vp = (float4)(gvelo_loc[i_ind_p.x], gvelo_loc[i_ind_p.y],
+ gvelo_loc[i_ind_p.z], gvelo_loc[i_ind_p.w]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 3 + WIDTH) % WIDTH);
+ barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (alpha(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (beta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (gamma(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (delta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (eta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (zeta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (theta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ index4 = (index4 + 1) % WIDTH;
+ //barrier(CLK_LOCAL_MEM_FENCE);
+ gs = (iota(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[i],gscal_loc[i+1], gscal_loc[i+2], gscal_loc[i+3]), (i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..1557aaffc403c7c27a56662ad550b8fb995819c5
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/advection_and_remesh_m8prime_3D_opt4_builtin_private4_noBC.cl
@@ -0,0 +1,115 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void advection_and_remeshing(__global const float* gvelo,
+ __global const float* pscal,
+ __global float* gscal,
+ float dt, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind, i_ind, i_ind_p;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs, v, vp, coord;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+ __local float gvelo_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ v = vload4((i+gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gvelo);
+ gvelo_loc[noBC_id(i, nb_part)] = v.x;
+ gvelo_loc[noBC_id(i+1, nb_part)] = v.y;
+ gvelo_loc[noBC_id(i+2, nb_part)] = v.z;
+ gvelo_loc[noBC_id(i+3, nb_part)] = v.w;
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ v = (float4)(gvelo_loc[noBC_id(i,nb_part)],
+ gvelo_loc[noBC_id(i+1,nb_part)],
+ gvelo_loc[noBC_id(i+2,nb_part)],
+ gvelo_loc[noBC_id(i+3,nb_part)]);
+ coord = (float4)(i*dx, (i+1)*dx, (i+2)*dx, (i+3)*dx);
+ p = fma((float4)(0.5*dt),v,coord);
+ ind = convert_int4_rtn(p * invdx);
+ y = (fma(- convert_float4(ind),dx,p))* invdx ;
+ i_ind = ((ind + WIDTH) % WIDTH);
+ i_ind_p = ((i_ind + 1) % WIDTH);
+ v = (float4)(gvelo_loc[noBC_id(i_ind.x,nb_part)], gvelo_loc[noBC_id(i_ind.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind.z,nb_part)], gvelo_loc[noBC_id(i_ind.w,nb_part)]);
+ vp = (float4)(gvelo_loc[noBC_id(i_ind_p.x,nb_part)], gvelo_loc[noBC_id(i_ind_p.y,nb_part)],
+ gvelo_loc[noBC_id(i_ind_p.z,nb_part)], gvelo_loc[noBC_id(i_ind_p.w,nb_part)]);
+ p=fma(mix(v,vp,y),dt,coord);
+
+ s = vload4((i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 3 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (theta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (iota(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i, nb_part)],gscal_loc[noBC_id(i+1, nb_part)], gscal_loc[noBC_id(i+2, nb_part)], gscal_loc[noBC_id(i+3, nb_part)]), (i + gidY*WIDTH+gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D.cl
new file mode 100644
index 0000000000000000000000000000000000000000..1af25c6d58beb24ead4e25dfbd21cb78adc64613
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D.cl
@@ -0,0 +1,14 @@
+
+__kernel void copy(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = get_group_id(0) * TILE_DIM_COPY + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index = xIndex + yIndex * WIDTH + zIndex*WIDTH*WIDTH;
+
+ for(uint i=0; i<TILE_DIM_COPY; i+=BLOCK_ROWS_COPY)
+ {
+ out[index + i*WIDTH] = in[index + i*WIDTH];
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D_opt2.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D_opt2.cl
new file mode 100644
index 0000000000000000000000000000000000000000..7c2f3a950f744724775bea503cf69131095c13b8
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_2D_opt2.cl
@@ -0,0 +1,17 @@
+
+__kernel void copy(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = (get_group_id(0) * TILE_DIM_COPY + get_local_id(0)*2);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY + get_local_id(1);
+ uint index = xIndex + yIndex * WIDTH;
+ float x,y;
+
+ for(uint i=0; i<TILE_DIM_COPY; i+=BLOCK_ROWS_COPY)
+ {
+ x = in[index + i*WIDTH];
+ y = in[index + 1 + i*WIDTH];
+ out[index + i*WIDTH] = x;
+ out[index + 1 + i*WIDTH] = y;
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_locMem.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_locMem.cl
new file mode 100644
index 0000000000000000000000000000000000000000..b13c4b735ca5000ba8697cdfd43aa0cf024a789c
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_locMem.cl
@@ -0,0 +1,21 @@
+
+__kernel void copy(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = get_group_id(0) * TILE_DIM_COPY + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index = xIndex + yIndex * WIDTH + zIndex*WIDTH*WIDTH;
+
+ __local float tile[TILE_DIM_COPY][TILE_DIM_COPY];
+
+ for(uint i=0; i<TILE_DIM_COPY; i+=BLOCK_ROWS_COPY)
+ {
+ tile[get_local_id(1)+i][get_local_id(0)] = in[index + i*WIDTH];
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_COPY; i+=BLOCK_ROWS_COPY)
+ {
+ out[index + i*WIDTH] = tile[get_local_id(1)+i][get_local_id(0)];
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_opt4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_opt4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..e5bec1c04df53e5b901db18b6c959bbc4443fb55
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/copy_3D_opt4.cl
@@ -0,0 +1,22 @@
+
+__kernel void copy(__global const float* in,
+ __global float* out)
+{
+ uint xIndex = (get_group_id(0) * TILE_DIM_COPY + get_local_id(0)*4);
+ uint yIndex = get_group_id(1) * TILE_DIM_COPY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index = xIndex + yIndex * WIDTH + zIndex*WIDTH*WIDTH;
+ float x,y,z,w;
+
+ for(uint i=0; i<TILE_DIM_COPY; i+=BLOCK_ROWS_COPY)
+ {
+ x = in[index + i*WIDTH];
+ y = in[index + 1 + i*WIDTH];
+ z = in[index + 2 + i*WIDTH];
+ w = in[index + 3 + i*WIDTH];
+ out[index + i*WIDTH] = x;
+ out[index + 1 + i*WIDTH] = y;
+ out[index + 2 + i*WIDTH] = z;
+ out[index + 3 + i*WIDTH] = w;
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..895250723bdd1eaa04357817122fd5205eb10e1c
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_noBC.cl
@@ -0,0 +1,90 @@
+/**
+ * Local memory as a 2D array to avoid bank conflicts.
+ *
+ * @param id Index 1D
+ * @param nb_part Particle number per work-item
+ *
+ * @return Index in a 2D space.
+ */
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+
+/**
+ * 2D Remeshing kernel.
+ *
+ * @param ppos Particle position
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param min_position Domain lower point
+ * @param dx Space step
+ */
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gscal_loc[noBC_id(index4.x,nb_part)] += (alpha(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (alpha(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (alpha(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (alpha(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (beta(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (beta(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (beta(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (beta(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (gamma(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (gamma(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (gamma(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (gamma(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (delta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (delta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (delta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (delta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (eta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (eta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (eta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (eta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gscal_loc[noBC_id(index4.x,nb_part)] += (zeta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (zeta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (zeta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (zeta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i,nb_part)],gscal_loc[noBC_id(i+1,nb_part)], gscal_loc[noBC_id(i+2,nb_part)], gscal_loc[noBC_id(i+3,nb_part)]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..bd831d5abf3d791b984c67d3e4dee9d3b447f004
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4.cl
@@ -0,0 +1,76 @@
+
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[index4.x]+= gs.x;
+ gscal_loc[index4.y]+= gs.y;
+ gscal_loc[index4.z]+= gs.z;
+ gscal_loc[index4.w]+= gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[i],gscal_loc[i+1], gscal_loc[i+2], gscal_loc[i+3]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..014edd31671f10731a58ba826b876bb5bf612fa1
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_2D_opt4_private4_noBC.cl
@@ -0,0 +1,79 @@
+
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[noBC_id(index4.x, nb_part)] += gs.x;
+ gscal_loc[noBC_id(index4.y, nb_part)] += gs.y;
+ gscal_loc[noBC_id(index4.z, nb_part)] += gs.z;
+ gscal_loc[noBC_id(index4.w, nb_part)] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i, nb_part)],gscal_loc[noBC_id(i+1, nb_part)], gscal_loc[noBC_id(i+2, nb_part)], gscal_loc[noBC_id(i+3, nb_part)]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_3D_opt4_private4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_3D_opt4_private4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..eb67791af74bdfb46e79c38c87fcc216d5fc6032
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_3D_opt4_private4.cl
@@ -0,0 +1,81 @@
+
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 2 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[index4.x]+= gs.x;
+ gscal_loc[index4.y]+= gs.y;
+ gscal_loc[index4.z]+= gs.z;
+ gscal_loc[index4.w]+= gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[i],
+ gscal_loc[i+1],
+ gscal_loc[i+2],
+ gscal_loc[i+3]),
+ (i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_2D_opt4_noBC.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_2D_opt4_noBC.cl
new file mode 100644
index 0000000000000000000000000000000000000000..69fddc7f9bb90909b6bdd13a08a9c203923fb1d8
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_2D_opt4_noBC.cl
@@ -0,0 +1,102 @@
+/**
+ * Local memory as a 2D array to avoid bank conflicts.
+ *
+ * @param id Index 1D
+ * @param nb_part Particle number per work-item
+ *
+ * @return Index in a 2D space.
+ */
+inline uint noBC_id(int id, int nb_part){
+ return (id%nb_part)*WGN+(id/nb_part);
+}
+
+/**
+ * 2D Remeshing kernel.
+ *
+ * @param ppos Particle position
+ * @param pscal Particle scalar
+ * @param gscal Grid scalar
+ * @param min_position Domain lower point
+ * @param dx Space step
+ */
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 3 + WIDTH) % WIDTH); // i-3
+ gscal_loc[noBC_id(index4.x,nb_part)] += (alpha(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (alpha(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (alpha(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (alpha(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i-2
+ gscal_loc[noBC_id(index4.x,nb_part)] += (beta(y.x,s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (beta(y.y,s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (beta(y.z,s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (beta(y.w,s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i-1
+ gscal_loc[noBC_id(index4.x,nb_part)] += (gamma(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (gamma(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (gamma(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (gamma(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i
+ gscal_loc[noBC_id(index4.x,nb_part)] += (delta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (delta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (delta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (delta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; //i+1
+ gscal_loc[noBC_id(index4.x,nb_part)] += (eta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (eta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (eta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (eta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i+2
+ gscal_loc[noBC_id(index4.x,nb_part)] += (zeta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (zeta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (zeta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (zeta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i+3
+ gscal_loc[noBC_id(index4.x,nb_part)] += (theta(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (theta(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (theta(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (theta(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH; // i+4
+ gscal_loc[noBC_id(index4.x,nb_part)] += (iota(y.x, s.x));
+ gscal_loc[noBC_id(index4.y,nb_part)] += (iota(y.y, s.y));
+ gscal_loc[noBC_id(index4.z,nb_part)] += (iota(y.z, s.z));
+ gscal_loc[noBC_id(index4.w,nb_part)] += (iota(y.w, s.w));
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[noBC_id(i,nb_part)],gscal_loc[noBC_id(i+1,nb_part)], gscal_loc[noBC_id(i+2,nb_part)], gscal_loc[noBC_id(i+3,nb_part)]), (i + gidY*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_3D_opt4_private4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_3D_opt4_private4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..6af20d0051b110db5a4fc0846aa40a70f700894b
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/remeshing_m8prime_3D_opt4_private4.cl
@@ -0,0 +1,95 @@
+
+__kernel void remeshing(__global const float* ppos,
+ __global const float* pscal,
+ __global float* gscal, float min_position, float dx)
+{
+ uint gidX = get_global_id(0);
+ uint gidY = get_global_id(1);
+ uint gidZ = get_global_id(2);
+ float invdx = 1.0/dx;
+ int4 ind;
+ uint i, nb_part = WIDTH/WGN;
+ float4 p, s, y, gs;
+ uint4 index4;
+
+ __local float gscal_loc[WIDTH];
+
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ {
+ gscal_loc[i] = 0.0;
+ gscal_loc[i+1] = 0.0;
+ gscal_loc[i+2] = 0.0;
+ gscal_loc[i+3] = 0.0;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*nb_part; i<(gidX + 1)*nb_part; i+=4)
+ {
+ p = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, ppos) - (float4)(min_position);
+ s = vload4((i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, pscal);
+ ind = convert_int4_rtn(p * invdx);
+ y = (p - convert_float4(ind) * dx) * invdx;
+ index4 = convert_uint4((ind - 3 + WIDTH) % WIDTH);
+ gs = (alpha(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (beta(y, s));
+ gscal_loc[index4.x]+= gs.x;
+ gscal_loc[index4.y]+= gs.y;
+ gscal_loc[index4.z]+= gs.z;
+ gscal_loc[index4.w]+= gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (gamma(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (delta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (eta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (zeta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (theta(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ index4 = (index4 + 1) % WIDTH;
+ gs = (iota(y, s));
+ gscal_loc[index4.x] += gs.x;
+ gscal_loc[index4.y] += gs.y;
+ gscal_loc[index4.z] += gs.z;
+ gscal_loc[index4.w] += gs.w;
+ barrier(CLK_LOCAL_MEM_FENCE);
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(i=gidX*4; i<WIDTH; i+=(WGN*4))
+ vstore4((float4)(gscal_loc[i],
+ gscal_loc[i+1],
+ gscal_loc[i+2],
+ gscal_loc[i+3]),
+ (i + gidY*WIDTH + gidZ*WIDTH*WIDTH)/4, gscal);
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_2D_xy_coalesced_locPad_Diag_opt4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_2D_xy_coalesced_locPad_Diag_opt4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..b6853e37ba37b97e35fbf8a7d224acfcbda7c5a2
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_2D_xy_coalesced_locPad_Diag_opt4.cl
@@ -0,0 +1,36 @@
+
+__kernel void transpose_xy(__global const float* in,
+ __global float* out)
+{
+ float4 temp;
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XY + get_local_id(0)*4;
+ uint yIndex = group_id_y * TILE_DIM_XY + get_local_id(1);
+ uint index_in = xIndex + yIndex * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_XY + get_local_id(0)*4;
+ yIndex = group_id_x * TILE_DIM_XY + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH;
+
+ __local float tile[TILE_DIM_XY][TILE_DIM_XY+1];
+
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = vload4((index_in + i*WIDTH)/4, in);
+ tile[get_local_id(1) + i][get_local_id(0)*4] = temp.x;
+ tile[get_local_id(1) + i][get_local_id(0)*4+1] = temp.y;
+ tile[get_local_id(1) + i][get_local_id(0)*4+2] = temp.z;
+ tile[get_local_id(1) + i][get_local_id(0)*4+3] = temp.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = (float4)(tile[get_local_id(0)*4][get_local_id(1) + i],
+ tile[get_local_id(0)*4+1][get_local_id(1) + i],
+ tile[get_local_id(0)*4+2][get_local_id(1) + i],
+ tile[get_local_id(0)*4+3][get_local_id(1) + i]);
+ vstore4(temp, (index_out + i*WIDTH)/4, out);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt2.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt2.cl
new file mode 100644
index 0000000000000000000000000000000000000000..f94717ae5827d2b0bdd50d9d27da32336e935aef
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt2.cl
@@ -0,0 +1,33 @@
+
+__kernel void transpose_xy(__global const float* in,
+ __global float* out)
+{
+ float2 temp;
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XY + get_local_id(0)*2;
+ uint yIndex = group_id_y * TILE_DIM_XY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_XY + get_local_id(0)*2;
+ yIndex = group_id_x * TILE_DIM_XY + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_XY][TILE_DIM_XY+1];
+
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = vload2((index_in + i*WIDTH)/2, in);
+ tile[get_local_id(1) + i][get_local_id(0)*2] = temp.x;
+ tile[get_local_id(1) + i][get_local_id(0)*2+1] = temp.y;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = (float2)(tile[get_local_id(0)*2][get_local_id(1) + i],
+ tile[get_local_id(0)*2+1][get_local_id(1) + i]);
+ vstore2(temp, (index_out + i*WIDTH)/2, out);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..e8afa56b9744f41d70327adde3541c83d0f17806
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_2Dslice_opt4.cl
@@ -0,0 +1,37 @@
+
+__kernel void transpose_xy(__global const float* in,
+ __global float* out)
+{
+ float4 temp;
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XY + get_local_id(0)*4;
+ uint yIndex = group_id_y * TILE_DIM_XY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_XY + get_local_id(0)*4;
+ yIndex = group_id_x * TILE_DIM_XY + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_XY][TILE_DIM_XY+1];
+
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = vload4((index_in + i*WIDTH)/4, in);
+ tile[get_local_id(1) + i][get_local_id(0)*4] = temp.x;
+ tile[get_local_id(1) + i][get_local_id(0)*4+1] = temp.y;
+ tile[get_local_id(1) + i][get_local_id(0)*4+2] = temp.z;
+ tile[get_local_id(1) + i][get_local_id(0)*4+3] = temp.w;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = (float4)(tile[get_local_id(0)*4][get_local_id(1) + i],
+ tile[get_local_id(0)*4+1][get_local_id(1) + i],
+ tile[get_local_id(0)*4+2][get_local_id(1) + i],
+ tile[get_local_id(0)*4+3][get_local_id(1) + i]);
+ vstore4(temp, (index_out + i*WIDTH)/4, out);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_opt2.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_opt2.cl
new file mode 100644
index 0000000000000000000000000000000000000000..f94717ae5827d2b0bdd50d9d27da32336e935aef
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xy_coalesced_locPad_Diag_opt2.cl
@@ -0,0 +1,33 @@
+
+__kernel void transpose_xy(__global const float* in,
+ __global float* out)
+{
+ float2 temp;
+ uint group_id_x = get_group_id(0);
+ uint group_id_y = (get_group_id(0) + get_group_id(1)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XY + get_local_id(0)*2;
+ uint yIndex = group_id_y * TILE_DIM_XY + get_local_id(1);
+ uint zIndex = get_global_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_y * TILE_DIM_XY + get_local_id(0)*2;
+ yIndex = group_id_x * TILE_DIM_XY + get_local_id(1);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_XY][TILE_DIM_XY+1];
+
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = vload2((index_in + i*WIDTH)/2, in);
+ tile[get_local_id(1) + i][get_local_id(0)*2] = temp.x;
+ tile[get_local_id(1) + i][get_local_id(0)*2+1] = temp.y;
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint i=0; i<TILE_DIM_XY; i+=BLOCK_ROWS_XY)
+ {
+ temp = (float2)(tile[get_local_id(0)*2][get_local_id(1) + i],
+ tile[get_local_id(0)*2+1][get_local_id(1) + i]);
+ vstore2(temp, (index_out + i*WIDTH)/2, out);
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_Diag_bis_3DBlock.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_Diag_bis_3DBlock.cl
new file mode 100644
index 0000000000000000000000000000000000000000..67e8891bd6910bb0d2463ec367f10a11d8aa5ba8
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_Diag_bis_3DBlock.cl
@@ -0,0 +1,34 @@
+
+__kernel void transpose_xz(__global const float* in,
+ __global float* out)
+{
+ uint group_id_x = get_group_id(0);
+ uint group_id_z = (get_group_id(0) + get_group_id(2)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XZ + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_XZ + get_local_id(1);
+ uint zIndex = group_id_z * TILE_DIM_XZ + get_local_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_z * TILE_DIM_XZ + get_local_id(0);
+ zIndex = group_id_x * TILE_DIM_XZ + get_local_id(2);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_XZ][TILE_DIM_XZ][TILE_DIM_XZ];
+
+ for(uint j=0; j<TILE_DIM_XZ; j+=BLOCK_ROWS_XZ)
+ {
+ for(uint i=0; i<TILE_DIM_XZ; i+=BLOCK_ROWS_XZ)
+ {
+ tile[get_local_id(2) + j][get_local_id(1) + i][get_local_id(0)] = in[index_in + i*WIDTH + j*WIDTH*WIDTH];
+ }
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint j=0; j<TILE_DIM_XZ; j+=BLOCK_ROWS_XZ)
+ {
+ for(uint i=0; i<TILE_DIM_XZ; i+=BLOCK_ROWS_XZ)
+ {
+ out[index_out + i*WIDTH + j*WIDTH*WIDTH] = tile[get_local_id(0)][get_local_id(1)+i][get_local_id(2) + j];
+ }
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_locPad_Diag_bis_3DBlock.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_locPad_Diag_bis_3DBlock.cl
new file mode 100644
index 0000000000000000000000000000000000000000..a112ea1993e8885aa57c845d09120b466a57d21f
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/transpose_3D_xz_coalesced_locPad_Diag_bis_3DBlock.cl
@@ -0,0 +1,34 @@
+
+__kernel void transpose_xz(__global const float* in,
+ __global float* out)
+{
+ uint group_id_x = get_group_id(0);
+ uint group_id_z = (get_group_id(0) + get_group_id(2)) % get_num_groups(0);
+
+ uint xIndex = group_id_x * TILE_DIM_XZ + get_local_id(0);
+ uint yIndex = get_group_id(1) * TILE_DIM_XZ + get_local_id(1);
+ uint zIndex = group_id_z * TILE_DIM_XZ + get_local_id(2);
+ uint index_in = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ xIndex = group_id_z * TILE_DIM_XZ + get_local_id(0);
+ zIndex = group_id_x * TILE_DIM_XZ + get_local_id(2);
+ uint index_out = xIndex + yIndex * WIDTH + zIndex * WIDTH * WIDTH;
+
+ __local float tile[TILE_DIM_XZ][TILE_DIM_XZ][TILE_DIM_XZ+1];
+
+ for(uint j=0; j<TILE_DIM_XZ; j+=BLOCK_ROWS_XZ)
+ {
+ for(uint i=0; i<TILE_DIM_XZ; i+=BLOCK_ROWS_XZ)
+ {
+ tile[get_local_id(2) + j][get_local_id(1) + i][get_local_id(0)] = in[index_in + i*WIDTH + j*WIDTH*WIDTH];
+ }
+ }
+ barrier(CLK_LOCAL_MEM_FENCE);
+ for(uint j=0; j<TILE_DIM_XZ; j+=BLOCK_ROWS_XZ)
+ {
+ for(uint i=0; i<TILE_DIM_XZ; i+=BLOCK_ROWS_XZ)
+ {
+ out[index_out + i*WIDTH + j*WIDTH*WIDTH] = tile[get_local_id(0)][get_local_id(1)+i][get_local_id(2) + j];
+ }
+ }
+}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime.cl
new file mode 100644
index 0000000000000000000000000000000000000000..cd21a32e74bff85d463b68da55d44bd8f83749ee
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime.cl
@@ -0,0 +1,20 @@
+/**
+ * M6prime weights.
+ *
+ * @param y Distance between the particle and left-hand grid point
+ * @param s Scalar of the particle
+ *
+ * @return weights
+ */
+inline float alpha(float y, float s){
+ return (y * (y * (y * (y * (13.0 - 5.0 * y) - 9.0) - 1.0) + 2.0) / 24.0) * s;}
+inline float beta(float y, float s){
+ return (y * (y * (y * (y * (25.0 * y - 64.0) + 39.0) + 16.0) - 16.0) / 24.0)*s;}
+inline float gamma(float y, float s){
+ return (y * y * (y * (y * (126.0 - 50.0 * y) - 70.0) - 30.0) / 24.0 + 1.0)*s;}
+inline float delta(float y, float s){
+ return (y * (y * (y * (y * (50.0 * y - 124.0) + 66.0) + 16.0) + 16.0) / 24.0)*s;}
+inline float eta(float y, float s){
+ return (y * (y * (y * (y * (61.0 - 25.0 * y) - 33.0) - 1.0) - 2.0) / 24.0)*s;}
+inline float zeta(float y, float s){
+ return (y * y * y * (y * (5.0 * y - 12.0) + 7.0) / 24.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..f63a419523ab10048ed59ca85cbb25e3e1326da1
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_builtin.cl
@@ -0,0 +1,13 @@
+
+inline float alpha(float y, float s){
+ return (y * fma(y , fma(y , fma(y , fma(-5.0, y, 13.0),- 9.0),- 1.0), 2.0) / 24.0) * s;}
+inline float beta(float y, float s){
+ return (y * fma(y , fma(y , fma(y , fma(25.0 , y ,- 64.0), 39.0) , 16.0), - 16.0) / 24.0)*s;}
+inline float gamma(float y, float s){
+ return (y * y * fma(y , fma(y , fma( - 50.0 , y, 126.0) ,- 70.0) ,- 30.0) / 24.0 + 1.0)*s;}
+inline float delta(float y, float s){
+ return (y * fma(y , fma(y, fma(y, fma(50.0, y, - 124.0), 66.0) , 16.0) , 16.0) / 24.0)*s;}
+inline float eta(float y, float s){
+ return (y * fma(y , fma(y , fma(y , fma(- 25.0 , y, 61.0), - 33.0), - 1.0), - 2.0) / 24.0)*s;}
+inline float zeta(float y, float s){
+ return (y * y * y * fma(y , fma(5.0 , y ,- 12.0) , 7.0) / 24.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4.cl
new file mode 100644
index 0000000000000000000000000000000000000000..865327f319211b18015e1ed556b7456c54b6cb7c
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4.cl
@@ -0,0 +1,13 @@
+
+inline float4 alpha(float4 y, float4 s){
+ return (y * (y * (y * (y * (13.0 - 5.0 * y) - 9.0) - 1.0) + 2.0) / 24.0) * s;}
+inline float4 beta(float4 y, float4 s){
+ return (y * (y * (y * (y * (25.0 * y - 64.0) + 39.0) + 16.0) - 16.0) / 24.0)*s;}
+inline float4 gamma(float4 y, float4 s){
+ return (y * y * (y * (y * (126.0 - 50.0 * y) - 70.0) - 30.0) / 24.0 + 1.0)*s;}
+inline float4 delta(float4 y, float4 s){
+ return (y * (y * (y * (y * (50.0 * y - 124.0) + 66.0) + 16.0) + 16.0) / 24.0)*s;}
+inline float4 eta(float4 y, float4 s){
+ return (y * (y * (y * (y * (61.0 - 25.0 * y) - 33.0) - 1.0) - 2.0) / 24.0)*s;}
+inline float4 zeta(float4 y, float4 s){
+ return (y * y * y * (y * (5.0 * y - 12.0) + 7.0) / 24.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..3a4c2eaeb63ee4317914062ddfb07a0fd38bb6a3
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m6prime_opt4_builtin.cl
@@ -0,0 +1,13 @@
+
+inline float4 alpha(float4 y, float4 s){
+ return (y * fma(y , fma(y , fma(y , fma(-5.0, y, 13.0),- 9.0),- 1.0), 2.0) / 24.0) * s;}
+inline float4 beta(float4 y, float4 s){
+ return (y * fma(y , fma(y , fma(y , fma(25.0 , y ,- 64.0), 39.0) , 16.0), - 16.0) / 24.0)*s;}
+inline float4 gamma(float4 y, float4 s){
+ return (y * y * fma(y , fma(y , fma( - 50.0 , y, 126.0) ,- 70.0) ,- 30.0) / 24.0 + 1.0)*s;}
+inline float4 delta(float4 y, float4 s){
+ return (y * fma(y , fma(y, fma(y, fma(50.0, y, - 124.0), 66.0) , 16.0) , 16.0) / 24.0)*s;}
+inline float4 eta(float4 y, float4 s){
+ return (y * fma(y , fma(y , fma(y , fma(- 25.0 , y, 61.0), - 33.0), - 1.0), - 2.0) / 24.0)*s;}
+inline float4 zeta(float4 y, float4 s){
+ return (y * y * y * fma(y , fma(5.0 , y ,- 12.0) , 7.0) / 24.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8_prime.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8_prime.cl
new file mode 100644
index 0000000000000000000000000000000000000000..84c4032b08603886ab2b8bb0c62f756d6206d7c5
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8_prime.cl
@@ -0,0 +1,31 @@
+/**
+ * M8prime weights.
+ *
+ * @param y Distance between the particle and left-hand grid point
+ * @param s Scalar of the particle
+ *
+ * @return weights
+ */
+inline float alpha(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(-10.0*y + 21.0) + 28.0) - 105.0) + 70.0) + 35.0) - 56.0) + 17.0) / 3360.0) * s;}
+
+inline float beta(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(70.0*y - 175.0) - 140.0) + 770.0) - 560.0) - 350.0) + 504.0) - 102.0) / 3360.0)*s;}
+
+inline float gamma(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(-210.0*y + 609.0) + 224.0) - 2135.0) + 910.0) + 2765.0) - 2520.0) + 255.0) / 3360.0)*s;}
+
+inline float delta(float y, float s){
+ return ((y*y*(y*y*(y*y*(70.0*y - 231.0) + 588.0) - 980.0) + 604.0) / 672.0)*s;}
+
+inline float eta(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(-70.0*y + 259.0) - 84.0) - 427.0) - 182.0) + 553.0) + 504.0) + 51.0) / 672.0)*s;}
+
+inline float zeta(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(210.0*y - 861.0) + 532.0) + 770.0) + 560.0) - 350.0) - 504.0) - 102.0) / 3360.0)*s;}
+
+inline float theta(float y, float s){
+ return ((y*(y*(y*(y*(y*(y*(-70.0*y + 315.0) - 280.0) - 105.0) - 70.0) + 35.0) + 56.0) + 17.0) / 3360.0)*s;}
+
+inline float iota(float y, float s){
+ return ((y*y*y*y*y*(y*(10.*y - 49.) + 56.))/3360.)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..94d393d333c91e7404f2c7e4ce8a58b2683a8189
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_builtin.cl
@@ -0,0 +1,33 @@
+/**
+ * M8prime weights.
+ *
+ * @param y Distance between the particle and left-hand grid point
+ * @param s Scalar of the particle
+ *
+ * @return weights
+ *
+ * Use OpenCL fma builtin function.
+ */
+inline float alpha(float y, float s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-10.0,y, + 21.0), + 28.0), - 105.0), + 70.0), + 35.0), - 56.0), + 17.0) / 3360.0) * s;}
+
+inline float beta(float y, float s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(70.0,y, - 175.0), - 140.0), + 770.0), - 560.0), - 350.0), + 504.0), - 102.0) / 3360.0)*s;}
+
+inline float gamma(float y, float s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-210.0,y, + 609.0), + 224.0), - 2135.0), + 910.0), + 2765.0), - 2520.0), + 255.0) / 3360.0)*s;}
+
+inline float delta(float y, float s){
+ return (fma(y*y, fma(y*y, fma(y*y, fma(70.0,y, - 231.0), + 588.0), - 980.0), + 604.0) / 672.0)*s;}
+
+inline float eta(float y, float s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-70.0,y, 259.0), - 84.0), - 427.0), - 182.0), + 553.0), + 504.0), + 51.0) / 672.0)*s;}
+
+inline float zeta(float y, float s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(210.0,y,- 861.0), + 532.0), + 770.0), + 560.0), - 350.0), - 504.0), - 102.0) / 3360.0)*s;}
+
+inline float theta(float y, float s){
+ return (fma(y, fma(y, fma(y, fma(y, fma(y, fma(y, fma(-70.0, y, 315.0), -280.0), -105.0), -70.0), 35.0), 56.0), 17.0) / 3360.0)*s;}
+
+inline float iota(float y, float s){
+ return ((y * y * y * y * y * fma(y , fma(10.0 , y ,- 49.0) , 56.0)) / 3360.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_opt4_builtin.cl b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_opt4_builtin.cl
new file mode 100644
index 0000000000000000000000000000000000000000..90f28e492a222e5cadf18f25227db59e3c8a51a4
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/gpu_src/weights_m8prime_opt4_builtin.cl
@@ -0,0 +1,33 @@
+/**
+ * M8prime weights.
+ *
+ * @param y Distance between the particle and left-hand grid point
+ * @param s Scalar of the particle
+ *
+ * @return weights
+ *
+ * Use OpenCL fma builtin function, computed by float4.
+ */
+inline float4 alpha(float4 y, float4 s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-10.0,y, + 21.0), + 28.0), - 105.0), + 70.0), + 35.0), - 56.0), + 17.0) / 3360.0) * s;}
+
+inline float4 beta(float4 y, float4 s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(70.0,y, - 175.0), - 140.0), + 770.0), - 560.0), - 350.0), + 504.0), - 102.0) / 3360.0)*s;}
+
+inline float4 gamma(float4 y, float4 s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-210.0,y, + 609.0), + 224.0), - 2135.0), + 910.0), + 2765.0), - 2520.0), + 255.0) / 3360.0)*s;}
+
+inline float4 delta(float4 y, float4 s){
+ return (fma(y*y, fma(y*y, fma(y*y, fma(70.0,y, - 231.0), + 588.0), - 980.0), + 604.0) / 672.0)*s;}
+
+inline float4 eta(float4 y, float4 s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(-70.0,y, 259.0), - 84.0), - 427.0), - 182.0), + 553.0), + 504.0), + 51.0) / 672.0)*s;}
+
+inline float4 zeta(float4 y, float4 s){
+ return (fma(y,fma(y,fma(y,fma(y,fma(y,fma(y,fma(210.0,y,- 861.0), + 532.0), + 770.0), + 560.0), - 350.0), - 504.0), - 102.0) / 3360.0)*s;}
+
+inline float4 theta(float4 y, float4 s){
+ return (fma(y, fma(y, fma(y, fma(y, fma(y, fma(y, fma(-70.0, y, 315.0), -280.0), -105.0), -70.0), 35.0), 56.0), 17.0) / 3360.0)*s;}
+
+inline float4 iota(float4 y, float4 s){
+ return ((y * y * y * y * y * fma(y , fma(10.0 , y ,- 49.0) , 56.0)) / 3360.0)*s;}
diff --git a/HySoP/unusedOrObsolet/particular_solvers/interpolation/__init__.py b/HySoP/unusedOrObsolet/particular_solvers/interpolation/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/unusedOrObsolet/particular_solvers/interpolation/interpolation.py b/HySoP/unusedOrObsolet/particular_solvers/interpolation/interpolation.py
new file mode 100644
index 0000000000000000000000000000000000000000..308ca5ae3041808affab86ce73fbfc8e32e84c78
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/interpolation/interpolation.py
@@ -0,0 +1,36 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+InterpolationMethod interface.
+"""
+
+
+class InterpolationMethod:
+ """
+ Interpolation method interface.
+ """
+ def __init__(self):
+ """
+ Constructor.
+ """
+ ## Grid
+ self.grid = None
+ ## Values to interpolate
+ self.gvalues = None
+
+ def interpolate(self, ppos, grid, gvelo):
+ """
+ Abstract method, apply operaton on a variable.
+ Must be implemented by sub-class.
+
+ @param ppos : particle position.
+ @param grid : grid points.
+ @param gvelo : grid velocity field.
+ @return particle velocity, velocity at position ppos.
+ """
+ raise NotImplementedError("Need to override method in a subclass of " + providedClass)
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/interpolation/linear.py b/HySoP/unusedOrObsolet/particular_solvers/interpolation/linear.py
new file mode 100644
index 0000000000000000000000000000000000000000..38fe792b5c427f412eb05b5c657bcb078f1442b2
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/interpolation/linear.py
@@ -0,0 +1,193 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+InterpolationMethod interface.
+"""
+from ..Param import *
+from InterpolationMethod import InterpolationMethod
+
+
+providedClass = "Linear"
+
+
+class Linear(InterpolationMethod):
+ """
+ Lambda1 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+
+ @param grid : Grid values
+ @param gvalues : Values to interpolate
+ """
+ InterpolationMethod.__init__(self)
+ self.grid = grid
+ self.gvalues = gvalues
+ self.dim_range = xrange(self.grid.dimension)
+ self.nb_flop = 9
+
+ def interpolate(self, t, ppos, dir):
+ """
+ Abstract method, apply operaton on a variable.
+ Must be implemented by sub-class.
+
+ @param t : current time
+ @param ppos : particle position.
+ @param dir : interpolation direction
+ @return particle velocity, velocity at position ppos.
+ """
+ ind = np.empty(self.grid.shape, dtype=dtype_integer)
+ a0 = ((ppos - self.grid.min) / self.grid.elementSize)
+ ind[...] = (np.round(np.abs(a0))) * np.sign(a0)
+ ind[..., dir] = np.floor(a0[..., dir])
+ #ind[...] = (np.round(np.abs(a0))) * np.sign(a0)
+ index = [ind[..., i] for i in self.dim_range]
+ index[dir] = (index[dir] + self.grid.elementNumber[dir]) % self.grid.elementNumber[dir]
+ y = (ppos[..., dir] - self.grid[index][..., dir]) / self.grid.elementSize[dir]
+ res = np.copy(self.gvalues.values)
+ res[..., dir] = res[..., dir] * (1. - y)
+ index[dir] = (index[dir] + 1) % self.grid.elementNumber[dir]
+ res[..., dir] += self.gvalues.values[index][..., dir] * y
+ return res
+
+ def __call__(self, ppos, t, dir):
+ return self.interpolate(ppos, t, dir)
+
+ def __str__(self):
+ """ToString method"""
+ return "Linear"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
+
+
+class Linear2D(InterpolationMethod):
+ """
+ Lambda1 remeshing method implementation 2D.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def interpolate(self, t, ppos):
+ """
+ Linear interpolation.
+ Interpolate the velocity at the given particle position.
+
+ @param position : position to compute
+ @param grid Grid.Grid : grid data to interpolate
+ @return velocity : velocity at particle position
+ """
+ ii = xrange(len(ppos))
+ # Calcul des indices
+ ind = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXY = [(ind[i] % self.grid.elementNumber[i]) for i in ii]
+ iXpY = [iXY[i] for i in ii]
+ iXpY[0] = (iXpY[0] + 1) % self.grid.elementNumber[0]
+ iXYp = [iXY[i] for i in ii]
+ iXYp[1] = (iXYp[1] + 1) % self.grid.elementNumber[1]
+ iXpYp = [iXY[i] for i in ii]
+ iXpYp[0] = (iXpYp[0] + 1) % self.grid.elementNumber[0]
+ iXpYp[1] = (iXpYp[1] + 1) % self.grid.elementNumber[1]
+ # Calcul de la distance
+ y = [((ppos[i] - self.grid[iXY][i]) / self.grid.elementSize[i]) for i in ii]
+ # Calcul des poids
+ wXY = (1. - y[0]) * (1. - y[1])
+ wXpY = (y[0]) * (1. - y[1])
+ wXYp = (1. - y[0]) * (y[1])
+ wXpYp = (y[0]) * (y[1])
+ # Calcul du resultat
+ res = [0. for i in ii]
+ res = [res[i] + wXY * self.gvalues.values[tuple(iXY)][i] for i in ii]
+ res = [res[i] + wXpY * self.gvalues.values[tuple(iXpY)][i] for i in ii]
+ res = [res[i] + wXYp * self.gvalues.values[tuple(iXYp)][i] for i in ii]
+ res = [res[i] + wXpYp * self.gvalues.values[tuple(iXpYp)][i] for i in ii]
+ return res
+
+ def __call__(self, ppos, t):
+ return self.interpolate(ppos, t)
+
+ def __str__(self):
+ """ToString method"""
+ return "Linear"
+
+
+class Linear3D(InterpolationMethod):
+ """
+ Lambda1 remeshing method implementation 2D.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def interpolate(self, t, ppos):
+ """
+ Linear interpolation.
+ Interpolate the velocity at the given particle position.
+
+ @param position : position to compute
+ @param grid Grid.Grid : grid data to interpolate
+ @return velocity : velocity at particle position
+ """
+ ii = xrange(len(ppos))
+ # Calcul des indices
+ ind = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXYZ = [(ind[i] % self.grid.elementNumber[i]) for i in ii]
+ iXpYZ = [iXYZ[i] for i in ii]
+ iXpYZ[0] = (iXpYZ[0] + 1) % self.grid.elementNumber[0]
+ iXYpZ = [iXYZ[i] for i in ii]
+ iXYpZ[1] = (iXYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXYZp = [iXYZ[i] for i in ii]
+ iXYZp[2] = (iXYZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZ = [iXYZ[i] for i in ii]
+ iXpYpZ[0] = (iXpYpZ[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZ[1] = (iXpYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXpYZp = [iXYZ[i] for i in ii]
+ iXpYZp[0] = (iXpYZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYZp[2] = (iXpYZp[2] + 1) % self.grid.elementNumber[2]
+ iXYpZp = [iXYZ[i] for i in ii]
+ iXYpZp[1] = (iXYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXYpZp[2] = (iXYpZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZp = [iXYZ[i] for i in ii]
+ iXpYpZp[0] = (iXpYpZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZp[1] = (iXpYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXpYpZp[2] = (iXpYpZp[2] + 1) % self.grid.elementNumber[2]
+ # Calcul de la distance
+ y = [(ppos[i] - self.grid[iXYZ][i]) / self.grid.elementSize[i] for i in ii]
+ # Calcul des poids
+ wXYZ = (1. - y[0]) * (1. - y[1]) * (1. - y[2])
+ wXpYZ = (y[0]) * (1. - y[1]) * (1. - y[2])
+ wXYpZ = (1. - y[0]) * (y[1]) * (1. - y[2])
+ wXYZp = (1. - y[0]) * (1. - y[1]) * (y[2])
+ wXpYpZ = (y[0]) * (y[1]) * (1. - y[2])
+ wXpYZp = (y[0]) * (1. - y[1]) * (y[2])
+ wXYpZp = (1. - y[0]) * (y[1]) * (y[2])
+ wXpYpZp = (y[0]) * (y[1]) * (y[2])
+ # Calcul du resultat
+ res = [0. for i in ii]
+ res = [res[i] + wXYZ * self.gvalues.values[tuple(iXYZ)][i] for i in ii]
+ res = [res[i] + wXpYZ * self.gvalues.values[tuple(iXpYZ)][i] for i in ii]
+ res = [res[i] + wXYpZ * self.gvalues.values[tuple(iXYpZ)][i] for i in ii]
+ res = [res[i] + wXYZp * self.gvalues.values[tuple(iXYZp)][i] for i in ii]
+ res = [res[i] + wXpYpZ * self.gvalues.values[tuple(iXpYpZ)][i] for i in ii]
+ res = [res[i] + wXpYZp * self.gvalues.values[tuple(iXpYZp)][i] for i in ii]
+ res = [res[i] + wXYpZp * self.gvalues.values[tuple(iXYpZp)][i] for i in ii]
+ res = [res[i] + wXpYpZp * self.gvalues.values[tuple(iXpYpZp)][i] for i in ii]
+ return res
+
+ def __call__(self, ppos, t):
+ return self.interpolate(ppos, t)
+
+ def __str__(self):
+ """ToString method"""
+ return "Linear"
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/__init__.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/__init__.py
new file mode 100644
index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda1.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda1.py
new file mode 100644
index 0000000000000000000000000000000000000000..631b6370c225bf6fec3849d96c52f1240b12145e
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda1.py
@@ -0,0 +1,154 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RemeshingMethod interface.
+"""
+from RemeshingMethod import RemeshingMethod
+
+
+providedClass = "Lambda1"
+
+
+class Lambda1(RemeshingMethod):
+ """
+ Lambda1 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ raise Exception("Obsolete methods : Lambda1 (not implemented with tag)")
+ RemeshingMethod.__init__(self)
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal):
+ """
+ Abstract method, apply operaton on a variable.
+ Must be implemented by sub-class.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param gvalues : grid scalar field.
+ """
+ ii = xrange(len(ppos))
+ # Calcul des indices sur la grille
+ indGrid = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iX = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ iXp = [iX[i] for i in ii]
+ iXp[0] = (iXp[0] + 1) % self.grid.elementNumber[0]
+ # Calcul de la distance
+ y = [(ppos[i] - self.grid[iX][i]) / self.grid.elementSize[i] for i in ii]
+ # Remaillage
+ self.gvalues.values[tuple(iX)] += (1. - y[0]) * pscal
+ self.gvalues.values[tuple(iXp)] += y[0] * pscal
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda1 kernel"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
+
+
+class Lambda12D(RemeshingMethod):
+ """
+ Lambda1 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal):
+ """
+ \Lambda_1 2D tensorial remeshing kernel implementation.
+ Remesh the given particle on the grid according to \Lambda_1 remeshing kernel.
+
+ @param part Particle.Particle : particle to remesh
+ """
+ ii = xrange(len(ppos))
+ # Calcul des l'indices sur la grille
+ indGrid = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXY = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ iXpY = [iXY[i] for i in ii]
+ iXpY[0] = (iXpY[0] + 1) % self.grid.elementNumber[0]
+ iXYp = [iXY[i] for i in ii]
+ iXYp[1] = (iXYp[1] + 1) % self.grid.elementNumber[1]
+ iXpYp = [iXY[i] for i in ii]
+ iXpYp[0] = (iXpYp[0] + 1) % self.grid.elementNumber[0]
+ iXpYp[1] = (iXpYp[1] + 1) % self.grid.elementNumber[1]
+ # Calcul de la distance
+ y = [(ppos[i] - self.grid[iXY][i]) / self.grid.elementSize[i] for i in ii]
+ # Remaillage
+ self.gvalues.values[tuple(iXY)] += (1. - y[0]) * (1. - y[1]) * pscal
+ self.gvalues.values[tuple(iXpY)] += (y[0]) * (1. - y[1]) * pscal
+ self.gvalues.values[tuple(iXYp)] += (1. - y[0]) * (y[1]) * pscal
+ self.gvalues.values[tuple(iXpYp)] += (y[0]) * (y[1]) * pscal
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda1 kernel"
+
+
+class Lambda13D(RemeshingMethod):
+ """
+ Lambda1 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal):
+ """
+ \Lambda_1 3D tensorial remeshing kernel implementation.
+ Remesh the given particle on the grid according to \Lambda_1 remeshing kernel.
+
+ @param part Particle.Particle : particle to remesh
+ """
+ ii = xrange(len(ppos))
+ # Calcul des l'indices sur la grille
+ indGrid = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXYZ = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ iXpYZ = [iXYZ[i] for i in ii]
+ iXpYZ[0] = (iXpYZ[0] + 1) % self.grid.elementNumber[0]
+ iXYpZ = [iXYZ[i] for i in ii]
+ iXYpZ[1] = (iXYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXYZp = [iXYZ[i] for i in ii]
+ iXYZp[2] = (iXYZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZ = [iXYZ[i] for i in ii]
+ iXpYpZ[0] = (iXpYpZ[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZ[1] = (iXpYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXpYZp = [iXYZ[i] for i in ii]
+ iXpYZp[0] = (iXpYZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYZp[2] = (iXpYZp[2] + 1) % self.grid.elementNumber[2]
+ iXYpZp = [iXYZ[i] for i in ii]
+ iXYpZp[1] = (iXYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXYpZp[2] = (iXYpZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZp = [iXYZ[i] for i in ii]
+ iXpYpZp[0] = (iXpYpZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZp[1] = (iXpYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXpYpZp[2] = (iXpYpZp[2] + 1) % self.grid.elementNumber[2]
+ # Calcul des distances
+ y = [(ppos[i] - self.grid[iXYZ][i]) / self.grid.elementSize[i] for i in ii]
+ # Remaillage
+ self.gvalues.values[tuple(iXYZ)] += (1. - y[0]) * (1. - y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXpYZ)] += (y[0]) * (1. - y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXYpZ)] += (1. - y[0]) * (y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXYZp)] += (1. - y[0]) * (1. - y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXpYpZ)] += (y[0]) * (y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXpYZp)] += (y[0]) * (1. - y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXYpZp)] += (1. - y[0]) * (y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXpYpZp)] += (y[0]) * (y[1]) * (y[2]) * pscal
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda1 kernel"
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda2.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda2.py
new file mode 100644
index 0000000000000000000000000000000000000000..2436eda5670f34abc39618c73e3f3fdd333d6f96
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/remesh/lambda2.py
@@ -0,0 +1,303 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RemeshingMethod interface.
+"""
+from RemeshingMethod import RemeshingMethod
+import math
+
+providedClass = "Lambda2"
+
+
+class Lambda2(RemeshingMethod):
+ """
+ Lambda2 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ RemeshingMethod.__init__(self, grid, gvalues)
+ # Epsilon value to avoid rounding errors.
+ self.epsilon = self.grid.elementSize[0] * 0.000000001
+
+ def nint(self, x):
+ """
+ Nearest interger function.
+
+ @param x : real number.
+ @return : x nearest integer.
+ """
+ if x > -0.5:
+ return int(x + 0.5)
+ else:
+ return int(x + 0.5) - 1
+
+ def remesh_Tag_Center(self, ppos, pscal, pposP, pscalP, splittingDirection):
+ """
+ Remeshing method for Tagged Center particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param pposP : following particle position.
+ @param pscalP : following particle scalar.
+ @param splittingDirection : direction to remesh.
+ """
+ print "Remaillage Tag Centré"
+ ii = xrange(len(ppos))
+ d = splittingDirection
+ # Calcul des indices sur la grille
+ indGrid = [self.nint((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon) for i in ii]
+ indGrid_bis = [int(math.floor((pposP[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon)) for i in ii]
+ i0 = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ i0_bis = [indGrid_bis[i] % self.grid.elementNumber[i] for i in ii]
+ i0m = [(i0[i] - 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0p = [(i0[i] + 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # Calcul de la distance
+ x0 = (ppos[d] - i0[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ x0_bis = (pposP[d] - i0_bis[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ if x0 <= 0.5: # Article Table 2, case (d')
+ # Calcul des poids
+ a0m = 0.5 * x0 * (x0 - 1.)
+ a0 = 1. - a0m
+ b0p = 0.5 * x0_bis * (x0_bis + 1.)
+ b0 = 1. - b0p
+ else: # Article Table 2, case (c')
+ # Calcul des poids
+ a0m = 0.5 * (x0 - 1.) * (x0 - 2.)
+ a0 = 1. - a0m
+ b0p = 0.5 * x0_bis * (x0_bis + 1.)
+ b0 = 1. - b0p
+ # Remaillage
+ self.gvalues.values[tuple(i0m)] += pscal * a0m
+ self.gvalues.values[tuple(i0)] += pscal * a0 + pscalP * b0
+ self.gvalues.values[tuple(i0p)] += pscalP * b0p
+
+ def remesh_Tag_Left(self, ppos, pscal, pposP, pscalP, splittingDirection):
+ """
+ Remeshing method for Tagged Left particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param pposP : following particle position.
+ @param pscalP : following particle scalar.
+ @param splittingDirection : direction to remesh.
+ """
+ print "Remaillage Tag Left"
+ ii = xrange(len(ppos))
+ d = splittingDirection
+ # Calcul des indices sur la grille
+ indGrid = [int(math.floor((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon)) for i in ii]
+ indGrid_bis = [self.nint((pposP[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon) for i in ii]
+ i0 = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ i0_bis = [indGrid_bis[i] % self.grid.elementNumber[i] for i in ii]
+ i0m = [(i0[i] - 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0p = [(i0[i] + 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0p2 = [(i0[i] + 2) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0p3 = [(i0[i] + 3) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # Calcul de la distance
+ x0 = (ppos[d] - i0[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ x0_bis = (pposP[d] - i0_bis[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ if x0_bis <= 0.5: # Article Table 1, case (d)
+ # Calcul des poids
+ am = 0.5 * x0 * (x0 - 1.)
+ a0 = 1. - x0 * x0
+ ap = x0
+ ap2 = 0.5 * x0 * (x0 - 1.)
+ b0 = 0.5 * (x0_bis + 1.) * x0_bis
+ bp = -x0_bis
+ bp2 = 1. - x0_bis * x0_bis
+ bp3 = 0.5 * x0_bis * (x0_bis + 1.)
+ else: # Article Table 1, case (c)
+ # Calcul des poids
+ am = 0.5 * x0 * (x0 - 1.)
+ a0 = 1. - x0 * x0
+ ap = x0
+ ap2 = 0.5 * x0 * (x0 - 1.)
+ b0 = 0.5 * x0_bis * (x0_bis - 1.)
+ bp = 1. - x0_bis
+ bp2 = x0_bis * (2. - x0_bis)
+ bp3 = 0.5 * x0_bis * (x0_bis - 1.)
+ # Remaillage
+ self.gvalues.values[tuple(i0m)] += pscal * am
+ self.gvalues.values[tuple(i0)] += pscal * a0 + pscalP * b0
+ self.gvalues.values[tuple(i0p)] += pscal * ap + pscalP * bp
+ self.gvalues.values[tuple(i0p2)] += pscal * ap2 + pscalP * bp2
+ self.gvalues.values[tuple(i0p3)] += pscalP * bp3
+
+ def remesh_noTag_Center(self, ppos, pscal, splittingDirection):
+ """
+ Remeshong method for non-Tagged Center particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param splittingDirection : direction to remesh.
+ """
+ #print "Remaillage noTag Centre"
+ ii = xrange(len(ppos))
+ d = splittingDirection
+ # Calcul des indices sur la grille
+ indGrid = [self.nint((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon) for i in ii]
+ i0 = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ i0p = [(i0[i] + 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0p2 = [(i0[i] + 2) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0m = [(i0[i] - 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # Calcul de la distance
+ x0 = (ppos[d] - indGrid[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ if x0 <= 0.5:
+ # Calcul des poids
+ am = 0.5 * x0 * (x0 - 1.)
+ a0 = 1. - x0 * x0
+ ap = 0.5 * x0 * (x0 + 1.)
+ # Remaillage
+ self.gvalues.values[tuple(i0m)] += pscal * am
+ self.gvalues.values[tuple(i0)] += pscal * a0
+ self.gvalues.values[tuple(i0p)] += pscal * ap
+ else:
+ # Calcul des poids
+ am = 0.5 * (x0 - 1.) * (x0 - 2.)
+ a0 = x0 * (2. - x0)
+ ap = 0.5 * x0 * (x0 - 1.)
+ # Remaillage
+ self.gvalues.values[tuple(i0)] += pscal * am
+ self.gvalues.values[tuple(i0p)] += pscal * a0
+ self.gvalues.values[tuple(i0p2)] += pscal * ap
+
+ def remesh_noTag_Left(self, ppos, pscal, splittingDirection):
+ """
+ Remeshing method for non-Tagged Left particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param splittingDirection : direction to remesh.
+ """
+ #print "Remaillage no Tag Left"
+ ii = xrange(len(ppos))
+ d = splittingDirection
+ # Calcul des indices sur la grille
+ indGrid = [int(math.floor((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon)) for i in ii]
+ i0 = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ i0p = [(i0[i] + 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ i0m = [(i0[i] - 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # Calcul de la distance
+ x0 = (ppos[d] - indGrid[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ # Calcul des poids
+ am = 0.5 * x0 * (x0 - 1.)
+ a0 = 1. - x0 * x0
+ ap = 0.5 * x0 * (x0 + 1.)
+ # Remaillage
+ self.gvalues.values[tuple(i0m)] += pscal * am
+ self.gvalues.values[tuple(i0)] += pscal * a0
+ self.gvalues.values[tuple(i0p)] += pscal * ap
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda2 kernel"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
+
+
+class Lambda22D(RemeshingMethod):
+ """
+ Lambda2 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ raise Exception("Obsolete methods : Must use 1D version with splitting.")
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal):
+ """
+ \Lambda_1 2D tensorial remeshing kernel implementation.
+ Remesh the given particle on the grid according to \Lambda_1 remeshing kernel.
+
+ @param part Particle.Particle : particle to remesh
+ """
+ ii = xrange(len(ppos))
+ # Calcul des l'indices sur la grille
+ indGrid = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXY = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ iXpY = [iXY[i] for i in ii]
+ iXpY[0] = (iXpY[0] + 1) % self.grid.elementNumber[0]
+ iXYp = [iXY[i] for i in ii]
+ iXYp[1] = (iXYp[1] + 1) % self.grid.elementNumber[1]
+ iXpYp = [iXY[i] for i in ii]
+ iXpYp[0] = (iXpYp[0] + 1) % self.grid.elementNumber[0]
+ iXpYp[1] = (iXpYp[1] + 1) % self.grid.elementNumber[1]
+ # Calcul de la distance
+ y = [(ppos[i] - self.grid[iXY][i]) / self.grid.elementSize[i] for i in ii]
+ # Remaillage
+ self.gvalues.values[tuple(iXY)] += (1. - y[0]) * (1. - y[1]) * pscal
+ self.gvalues.values[tuple(iXpY)] += (y[0]) * (1. - y[1]) * pscal
+ self.gvalues.values[tuple(iXYp)] += (1. - y[0]) * (y[1]) * pscal
+ self.gvalues.values[tuple(iXpYp)] += (y[0]) * (y[1]) * pscal
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda2 kernel"
+
+
+class Lambda23D(RemeshingMethod):
+ """
+ Lambda2 remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ raise Exception("Obsolete methods : Must use 1D version with splitting.")
+ self.grid = grid
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal):
+ """
+ \Lambda_1 3D tensorial remeshing kernel implementation.
+ Remesh the given particle on the grid according to \Lambda_1 remeshing kernel.
+
+ @param part Particle.Particle : particle to remesh
+ """
+ ii = xrange(len(ppos))
+ # Calcul des l'indices sur la grille
+ indGrid = [int((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i]) for i in ii]
+ iXYZ = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ iXpYZ = [iXYZ[i] for i in ii]
+ iXpYZ[0] = (iXpYZ[0] + 1) % self.grid.elementNumber[0]
+ iXYpZ = [iXYZ[i] for i in ii]
+ iXYpZ[1] = (iXYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXYZp = [iXYZ[i] for i in ii]
+ iXYZp[2] = (iXYZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZ = [iXYZ[i] for i in ii]
+ iXpYpZ[0] = (iXpYpZ[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZ[1] = (iXpYpZ[1] + 1) % self.grid.elementNumber[1]
+ iXpYZp = [iXYZ[i] for i in ii]
+ iXpYZp[0] = (iXpYZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYZp[2] = (iXpYZp[2] + 1) % self.grid.elementNumber[2]
+ iXYpZp = [iXYZ[i] for i in ii]
+ iXYpZp[1] = (iXYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXYpZp[2] = (iXYpZp[2] + 1) % self.grid.elementNumber[2]
+ iXpYpZp = [iXYZ[i] for i in ii]
+ iXpYpZp[0] = (iXpYpZp[0] + 1) % self.grid.elementNumber[0]
+ iXpYpZp[1] = (iXpYpZp[1] + 1) % self.grid.elementNumber[1]
+ iXpYpZp[2] = (iXpYpZp[2] + 1) % self.grid.elementNumber[2]
+ # Calcul des distances
+ y = [(ppos[i] - self.grid[iXYZ][i]) / self.grid.elementSize[i] for i in ii]
+ # Remaillage
+ self.gvalues.values[tuple(iXYZ)] += (1. - y[0]) * (1. - y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXpYZ)] += (y[0]) * (1. - y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXYpZ)] += (1. - y[0]) * (y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXYZp)] += (1. - y[0]) * (1. - y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXpYpZ)] += (y[0]) * (y[1]) * (1. - y[2]) * pscal
+ self.gvalues.values[tuple(iXpYZp)] += (y[0]) * (1. - y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXYpZp)] += (1. - y[0]) * (y[1]) * (y[2]) * pscal
+ self.gvalues.values[tuple(iXpYpZp)] += (y[0]) * (y[1]) * (y[2]) * pscal
+
+ def __str__(self):
+ """ToString method"""
+ return "Lambda2 kernel"
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/m4p.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/m4p.py
new file mode 100644
index 0000000000000000000000000000000000000000..8c56a30d8ae2fed6efb5662b4bed0d6922630a1d
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/remesh/m4p.py
@@ -0,0 +1,87 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RemeshingMethod interface.
+"""
+from RemeshingMethod import RemeshingMethod
+import numpy as np
+import math
+
+providedClass = "M4Prime"
+
+
+class M4Prime(RemeshingMethod):
+ """
+ M4Prime remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ RemeshingMethod.__init__(self, grid, gvalues)
+ # Epsilon value to avoid rounding errors.
+ self.epsilon = self.grid.elementSize[0] * 0.000000001
+ self.dim_range = xrange(self.grid.dimension)
+
+ def remesh(self, ppos, pscal, dir):
+ """
+ Remeshing method for non-Tagged Left particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param dir : direction to remesh.
+ """
+ #print "Remaillage no Tag Left"
+ # ii = xrange(len(ppos))
+ # d = splittingDirection
+ # # Calcul des indices sur la grille
+ # indGrid = [int(math.floor((ppos[i] - self.grid.min[i]) / self.grid.elementSize[i] + self.epsilon)) for i in ii]
+ # i0 = [indGrid[i] % self.grid.elementNumber[i] for i in ii]
+ # i0p = [(i0[i] + 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # i0p2 = [(i0[i] + 2) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # i0m = [(i0[i] - 1) % self.grid.elementNumber[i] if i == d else i0[i] for i in ii]
+ # # Calcul de la distance
+ # x0 = (ppos[d] - indGrid[d] * self.grid.elementSize[d] - self.grid.min[d]) / self.grid.elementSize[d]
+ # # Calcul des poids
+ # am = -0.5 * x0 * (x0 - 1.) * (x0 - 1.)
+ # a0 = 0.5 * (x0 - 1.) * (3. * x0 * x0 - 2 * x0 - 2.)
+ # ap = 0.5 * x0 * (1. + 4. * x0 - 3. * x0 * x0)
+ # ap2 = 0.5 * x0 * x0 * (x0 - 1.)
+ # # Remaillage
+ # self.gvalues.values[tuple(i0m)] += pscal * am
+ # self.gvalues.values[tuple(i0)] += pscal * a0
+ # self.gvalues.values[tuple(i0p)] += pscal * ap
+ # self.gvalues.values[tuple(i0p2)] += pscal * ap2
+ ## ------------------- NumPy Optimisation
+ ind = ((ppos - self.grid.min) / self.grid.elementSize + self.epsilon).astype(np.int)
+ i0 = ind % self.grid.elementNumber
+ ip = np.copy(i0)
+ ip[..., dir] = (i0[..., dir] + 1) % self.grid.elementNumber[dir]
+ ip2 = np.copy(i0)
+ ip2[..., dir] = (i0[..., dir] + 2) % self.grid.elementNumber[dir]
+ im = np.copy(i0)
+ im[..., dir] = (i0[..., dir] - 1) % self.grid.elementNumber[dir]
+ i0 = tuple([i0[..., i] for i in self.dim_range])
+ ip = tuple([ip[..., i] for i in self.dim_range])
+ ip2 = tuple([ip2[..., i] for i in self.dim_range])
+ im = tuple([im[..., i] for i in self.dim_range])
+ x0 = (ppos[..., dir] - ind[..., dir] * self.grid.elementSize[dir] - self.grid.min[dir]) / self.grid.elementSize[dir]
+ am = -0.5 * x0 * (x0 - 1.) * (x0 - 1.)
+ a0 = 0.5 * (x0 - 1.) * (3. * x0 * x0 - 2 * x0 - 2.)
+ ap = 0.5 * x0 * (1. + 4. * x0 - 3. * x0 * x0)
+ ap2 = 0.5 * x0 * x0 * (x0 - 1.)
+ self.gvalues.values[i0] += pscal * a0
+ self.gvalues.values[im] += pscal * am
+ self.gvalues.values[ip] += pscal * ap
+ self.gvalues.values[ip2] += pscal * ap2
+ ## -------------------
+
+ def __str__(self):
+ """ToString method"""
+ return "M4Prime kernel"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : " + providedClass
+ print eval(providedClass).__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/m6p.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/m6p.py
new file mode 100644
index 0000000000000000000000000000000000000000..034ed3e546066edf1d09c6a38f5bc3e50a9bcae1
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/remesh/m6p.py
@@ -0,0 +1,75 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RemeshingMethod interface.
+"""
+from ..Param import *
+from RemeshingMethod import RemeshingMethod
+
+
+class M6Prime(RemeshingMethod):
+ """
+ M6Prime remeshing method implementation.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ RemeshingMethod.__init__(self, grid, gvalues)
+ self.dim_range = xrange(self.grid.dimension)
+ self.nb_flop = 106
+
+ def remesh(self, ppos, pscal, dir):
+ """
+ Remeshing method for non-Tagged Left particles.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param dir : direction to remesh.
+ """
+ ind = np.empty(self.grid.shape, dtype=dtype_integer)
+ a0 = ((ppos - self.grid.min) / self.grid.elementSize)
+ ind[...] = (np.round(np.abs(a0))) * np.sign(a0)
+ ind[..., dir] = np.floor(a0[..., dir])
+ x0 = (ppos[..., dir] - ind[..., dir] * self.grid.elementSize[dir] - self.grid.min[dir]) / self.grid.elementSize[dir]
+ am2 = x0 * (x0 * (x0 * (x0 * (-5. * x0 + 13.) - 9.) - 1.) + 2.) / 24.
+ am = x0 * (x0 * (x0 * (x0 * (25. * x0 - 64.) + 39.) + 16.) - 16.) / 24.
+ a0 = x0 * x0 * (x0 * (x0 * (-50. * x0 + 126.) - 70.) - 30.) / 24. + 1.
+ ap = x0 * (x0 * (x0 * (x0 * (50. * x0 - 124.) + 66.) + 16.) + 16.) / 24.
+ ap2 = x0 * (x0 * (x0 * (x0 * (-25. * x0 + 61.) - 33.) - 1.) - 2.) / 24.
+ ap3 = x0 * x0 * x0 * (x0 * (5. * x0 - 12.) + 7.) / 24.
+
+ ind[..., dir] = (ind[..., dir] - 2 + self.grid.elementNumber[dir]) % self.grid.elementNumber[dir]
+
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), am2.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ ind[..., dir] = (ind[..., dir] + 1) % self.grid.elementNumber[dir]
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), am.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ ind[..., dir] = (ind[..., dir] + 1) % self.grid.elementNumber[dir]
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), a0.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ ind[..., dir] = (ind[..., dir] + 1) % self.grid.elementNumber[dir]
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), ap.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ ind[..., dir] = (ind[..., dir] + 1) % self.grid.elementNumber[dir]
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), ap2.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ ind[..., dir] = (ind[..., dir] + 1) % self.grid.elementNumber[dir]
+ for i_index, ps, w in zip(ind.reshape((-1,self.grid.dimension)), pscal.reshape((-1)), ap3.reshape((-1))):
+ self.gvalues.values[tuple(i_index)] += ps * w
+
+ def __str__(self):
+ """ToString method"""
+ return "M6Prime kernel"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : M6Prime"
+ print M6Prime.__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/remesh/method.py b/HySoP/unusedOrObsolet/particular_solvers/remesh/method.py
new file mode 100644
index 0000000000000000000000000000000000000000..ade97b75ec7274dd855549e783ba124cd41d0434
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/remesh/method.py
@@ -0,0 +1,36 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RemeshingMethod interface.
+"""
+
+
+class RemeshingMethod:
+ """
+ Remeshing method interface.
+ """
+ def __init__(self, grid, gvalues):
+ """
+ Constructor.
+ """
+ ## Grid
+ self.grid = grid
+ ## Values to remesh
+ self.gvalues = gvalues
+
+ def remesh(self, ppos, pscal, grid, gscal):
+ """
+ Abstract method, apply operaton on a variable.
+ Must be implemented by sub-class.
+
+ @param ppos : particle position.
+ @param pscal : particle scalar.
+ @param grid : grid points.
+ @param gscal : grid scalar field.
+ """
+ raise NotImplementedError("Need to override method in a subclass of " + providedClass)
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : RemeshingMethod"
+ print RemeshingMethod.__doc__
diff --git a/HySoP/unusedOrObsolet/particular_solvers/solver.py b/HySoP/unusedOrObsolet/particular_solvers/solver.py
new file mode 100644
index 0000000000000000000000000000000000000000..4a01d273f7132b6911c26d788c683d01f7323a2d
--- /dev/null
+++ b/HySoP/unusedOrObsolet/particular_solvers/solver.py
@@ -0,0 +1,36 @@
+"""
+@package parmepy.particular_solvers.solver
+
+Solver class interface.
+"""
+from abc import ABCMeta, abstractmethod
+
+
+class Solver:
+ """
+ Solver interface.
+ """
+
+ __metaclass__ = ABCMeta
+
+ @abstractmethod
+ def __init__(self, problem):
+ """
+ Abstract constructor.
+ @param : the problem associated with this solver.
+ """
+ ## Problem to solve
+ self.problem = problem
+
+ @abstractmethod
+ def initialize(self):
+ """
+ Solver initialisation for a given DiscreteProblem.DiscreteProblem.
+ Abstract method, apply operaton on a variable.
+ Must be implemented by sub-class.
+ """
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : Solver (abstract)"
+ print Solver.__doc__
diff --git a/HySoP/unusedOrObsolet/runge_kutta.py b/HySoP/unusedOrObsolet/runge_kutta.py
new file mode 100644
index 0000000000000000000000000000000000000000..05bc5793e4d87a7fdec24ff4749b55c8f061d314
--- /dev/null
+++ b/HySoP/unusedOrObsolet/runge_kutta.py
@@ -0,0 +1,61 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RK2 method interface.
+"""
+from ..Param import *
+from ODESolver import ODESolver
+
+
+class RK2(ODESolver):
+ """
+ ODESolver implementation for solving an equation system with RK2 method.
+ y'(t) = f(t,y)
+
+ y(t_n+1)= y(t_n) + dt*y'[y(t_n)+dt/2*y'(y(t_n))].
+
+ """
+ def __init__(self, f=None, conditions=lambda x: x, dim=3):
+ """
+ Constructor.
+
+ @param f function f(t,y) : Right hand side of the equation to solve.
+ @param dim : dimensions
+ @param conditions : function to apply boundary conditions.
+ """
+ ODESolver.__init__(self, f)
+ # Boundary conditions function.
+ self.boundaryConditions = conditions
+ self.gpu_kernel = """
+ """
+ self.nb_flop = 5
+
+ def integrate(self, y, fy, yp, t, dt, dir):
+ """
+ Integration step for RK2 Method.
+ yp= y + dt*y'[y+dt/2*y'(y)].
+
+ @param y : position at time t.
+ @param fy : y'(y) value at time t.
+ @param yp : result position at time t + dt
+ @param t : current time.
+ @param dt : time step.
+ """
+ ## ------------------- NumPy Optimisation
+ p1 = np.copy(y[..., dir])
+ yp[..., dir] = p1 + fy[..., dir] * dt * 0.5
+ self.boundaryConditions(yp, dir) # TODO: A tester aussi avec return dans la fonction
+ vp1 = self.f(t, yp, dir)
+ yp[..., dir] = p1 + vp1[..., dir] * dt
+ self.boundaryConditions(yp, dir)
+ ## -------------------
+
+ def __str__(self):
+ """ToString method"""
+ return "RK2 Method"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : RK2"
+ print RK2.__doc__
diff --git a/HySoP/unusedOrObsolet/runge_kutta2stretching.py b/HySoP/unusedOrObsolet/runge_kutta2stretching.py
new file mode 100755
index 0000000000000000000000000000000000000000..bf2c868071dc7cee795783696720c32c48334b43
--- /dev/null
+++ b/HySoP/unusedOrObsolet/runge_kutta2stretching.py
@@ -0,0 +1,69 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RK2 method interface.
+"""
+from .integrator import ODESolver
+from ...operator.differentialOperator_d import DifferentialOperator_d
+from ...operator.differentialOperator import DifferentialOperator
+from parmepy.constants import *
+import copy
+import sys
+import numpy as np
+
+
+class RK2Stretch(ODESolver):
+ """
+ ODESolver implementation for solving an equation system with RK2 method.
+ y'(t) = f(t,y)
+
+ y(t_n+1)= y(t_n) + dt*y'[y(t_n)+dt/2*y'(y(t_n))].
+
+ """
+ def __init__(self, f=None, dim=3):
+ """
+ Constructor.
+
+ @param f function f(t,y) : Right hand side of the equation to solve.
+ @param dim : dimensions
+ @param conditions : function to apply boundary conditions.
+ """
+ ODESolver.__init__(self, f)
+
+
+ def integrate(self, f, fd ,field1 , field2, res_vorticity, t, dt, dimension):
+# def integrate(self, f,field1 , field2, res_vorticity, t, dt, dimension):
+ """
+ Integration step for RK4 Method
+ yp= y + dt*y'[y+dt/2*y'(y)].
+
+ @param y : position at time t.
+ @param f : operator to calcul y'(y) value at time t.
+ @param fd : result position at time t + dt
+ @param field1 : vorticity field discretized
+ @param field2 : velocity field discretized
+ @param t : current time.
+ @param dt : time step.
+ """
+ maxgersh = np.zeros(1, dtype=PARMES_REAL, order=ORDER)
+ resultTmp = np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K1=np.asarray(fd)
+ K1[:,:,:,:]= K1[:,:,:,:] *0.5*dt + field1[:,:,:]
+ if False in [(field1[i][...].shape == field2[i][...].shape) for i in xrange(dimension)] :
+ print "Error, not the same mesh on field1 and on field2"
+ f.discreteOperator = DifferentialOperator_d(field1=K1, field2=field2, result=resultTmp, choice='divConservation', maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ res_vorticity[:,:,:] = field1[:,:,:] + resultTmp[:,:,:,:] * dt
+ return res_vorticity
+
+
+
+ def __str__(self):
+ """ToString method"""
+ return "RK2 Method"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : RK2"
+ print RK2.__doc__
diff --git a/HySoP/unusedOrObsolet/runge_kutta3stretching.py b/HySoP/unusedOrObsolet/runge_kutta3stretching.py
new file mode 100644
index 0000000000000000000000000000000000000000..9d9c62ecff9912aa3d81384ff091f343c6cfb5e6
--- /dev/null
+++ b/HySoP/unusedOrObsolet/runge_kutta3stretching.py
@@ -0,0 +1,84 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RK3 method interface.
+"""
+from .integrator import ODESolver
+from ...operator.differentialOperator_d import DifferentialOperator_d
+from ...operator.differentialOperator import DifferentialOperator
+from parmepy.constants import *
+import numpy as np
+import copy
+
+class RK3Stretch(ODESolver):
+ """
+ ODESolver implementation for solving an equation system with RK3 method.
+ y'(t) = f(t,y)
+
+ y(t_n+1)= y(t_n) + dt*y'[y(t_n)+dt/2*y'(y(t_n))].
+
+ """
+ def __init__(self, f=None, dim=3):
+ """
+ Constructor.
+
+ @param f function f(t,y) : Right hand side of the equation to solve.
+ @param dim : dimensions
+ @param conditions : function to apply boundary conditions.
+ """
+ ODESolver.__init__(self, f)
+
+
+ def integrate(self, f, fd, field1, field2, res_vorticity, t, dt, dimension):
+ """
+ Integration step for RK3 Method
+ yp= y + dt*y'[y+dt/2*y'(y)].
+
+ @param y : position at time t.
+ @param f : operator to calcul y'(y) value at time t.
+ @param fd : result position at time t + dt
+ @param field1 : vorticity field discretized
+ @param field2 : velocity field discretized
+ @param t : current time.
+ @param dt : time step.
+ """
+ # RK3 TVD
+ maxgersh = np.zeros(1, dtype=PARMES_REAL, order=ORDER)
+ K1=np.asarray(fd)
+ K2=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K1[:,:,:,:] = field1[:,:,:] + dt * K1[:,:,:,:]
+ f.discreteOperator = DifferentialOperator_d(K1, field2, K2, choice='divConservation',maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ K2[:,:,:,:] = 3./4. * field1[:,:,:] + 1./4. * (K1[:,:,:,:] + dt * K2[:,:,:,:])
+ f.discreteOperator = DifferentialOperator_d(K2, field2, res_vorticity, choice='divConservation',maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ res_vorticity[:,:,:] = 1./3. * field1[:,:,:] + 2./3. * (K2[:,:,:,:] + dt * res_vorticity[:,:,:])
+ return res_vorticity
+
+ # RK3 V1
+# maxgersh = np.zeros(1, dtype=PARMES_REAL, order=ORDER)
+# K1=np.asarray(fd)
+# K2=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+# K3=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+# resultTmp = np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+# K1[:,:,:,:] = dt * K1[:,:,:,:]
+# resultTmp[:,:,:] = field1[:,:,:] + 1./3. * K1[:,:,:,:]
+# f.discreteOperator = DifferentialOperator_d(f, resultTmp, field2, K2, choice='divConservation',maxgersh=maxgersh)
+# f.discreteOperator.apply()
+# K2[:,:,:,:] = field1[:,:,:] + 2./3. * dt * K2[:,:,:,:]
+# f.discreteOperator = DifferentialOperator_d(f, K2, field2, K3, choice='divConservation',maxgersh=maxgersh)
+# f.discreteOperator.apply()
+# K3[:,:,:,:] = dt * K3[:,:,:,:]
+# res_vorticity[:,:,:] = field1[:,:,:] + 1./4. * (K1[:,:,:,:] + 3 * K3[:,:,:,:])
+# return res_vorticity
+
+
+ def __str__(self):
+ """ToString method"""
+ return "RK3 Method"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : RK3"
+ print RK3.__doc__
diff --git a/HySoP/unusedOrObsolet/runge_kutta4stretching.py b/HySoP/unusedOrObsolet/runge_kutta4stretching.py
new file mode 100755
index 0000000000000000000000000000000000000000..6427adefaff4a613feab97de4ae38494ae1f901a
--- /dev/null
+++ b/HySoP/unusedOrObsolet/runge_kutta4stretching.py
@@ -0,0 +1,77 @@
+# -*- coding: utf-8 -*-
+"""
+@package Utils
+RK4 method interface.
+"""
+from .integrator import ODESolver
+from ...operator.differentialOperator_d import DifferentialOperator_d
+from ...operator.differentialOperator import DifferentialOperator
+from parmepy.constants import *
+import numpy as np
+import copy
+
+class RK4Stretch(ODESolver):
+ """
+ ODESolver implementation for solving an equation system with RK4 method.
+ y'(t) = f(t,y)
+
+ y(t_n+1)= y(t_n) + dt*y'[y(t_n)+dt/2*y'(y(t_n))].
+
+ """
+ def __init__(self, f=None, dim=3):
+ """
+ Constructor.
+
+ @param f function f(t,y) : Right hand side of the equation to solve.
+ @param dim : dimensions
+ @param conditions : function to apply boundary conditions.
+ """
+ ODESolver.__init__(self, f)
+
+
+ def integrate(self, f, fd ,field1 , field2, res_vorticity, t, dt, dimension):
+ """
+ Integration step for RK4 Method
+ yp= y + dt*y'[y+dt/2*y'(y)].
+
+ @param y : position at time t.
+ @param f : operator to calcul y'(y) value at time t.
+ @param fd : result position at time t + dt
+ @param field1 : vorticity field discretized
+ @param field2 : velocity field discretized
+ @param t : current time.
+ @param dt : time step.
+ """
+ print "ehoh"
+ maxgersh = np.zeros(1, dtype=PARMES_REAL, order=ORDER)
+ resultTmp = np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K1=np.asarray(fd)
+ K2=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K3=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K4=np.asarray([np.zeros((field2.topology.resolution), dtype=PARMES_REAL, order=ORDER) for d in xrange(field2.topology.dim)])
+ K1[:,:,:,:] =K1[:,:,:,:]* dt
+ resultTmp[:,:,:,:] = K1[:,:,:,:] * 0.5 + field1[:,:,:]
+ f.discreteOperator = DifferentialOperator_d(resultTmp , field2, K2, choice='divConservation',maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ K2[:,:,:,:] = K2[:,:,:,:] * dt
+ resultTmp[:,:,:,:] = K2[:,:,:,:] * 0.5 + field1[:,:,:]
+ f.discreteOperator = DifferentialOperator_d(resultTmp, field2, K3, choice='divConservation',maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ K3[:,:,:,:] = K3[:,:,:,:] * dt
+ resultTmp[:,:,:,:] = K3[:,:,:,:] + field1[:,:,:]
+ f.discreteOperator = DifferentialOperator_d(resultTmp, field2, K4, choice='divConservation',maxgersh=maxgersh)
+ f.discreteOperator.apply()
+ K4[:,:,:,:] = K4[:,:,:,:] * dt
+ res_vorticity[:,:,:] = field1[:,:,:] + 1./6. * (K1[:,:,:,:] + 2.0 * K2[:,:,:,:] + 2.0 * K3[:,:,:,:] + K4[:,:,:,:])
+ return res_vorticity
+
+
+ def __str__(self):
+ """ToString method"""
+ return "RK4 Method"
+
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : RK4"
+ print RK4.__doc__
diff --git a/HySoP/unusedOrObsolet/splitting.py b/HySoP/unusedOrObsolet/splitting.py
new file mode 100644
index 0000000000000000000000000000000000000000..97f73668941e47df655220e8f29e67c33e23e7e5
--- /dev/null
+++ b/HySoP/unusedOrObsolet/splitting.py
@@ -0,0 +1,91 @@
+"""
+@file splitting.py
+
+Splitting operator representation
+"""
+from parmepy.numerics.method import NumMethod
+
+
+class Splitting(NumMethod):
+ """
+ Splitting operator representation.
+
+ Operator of operators applying in a Strang splitting.
+
+ Implements a 2nd order splitting in 3D:
+ @li X-dir, half time step
+ @li Y-dir, half time step
+ @li Z-dir, full time step
+ @li Y-dir, half time step
+ @li X-dir, half time step
+ \n
+ Implements a 2nd order splitting in 2D:
+ @li X-dir, half time step
+ @li Y-dir, full time step
+ @li X-dir, half time step
+ """
+
+ def __init__(self, function, dim, config='o2_FullHalf'):
+ """
+ Create a Splitting operator on a given list of operators
+ and a dimension.
+
+ @param function : function to split.
+ @param dim : problem dimension.
+ @param config : Splitting configuration :
+ - o2_FullHalf : All steps are performed with time step equals to dt/2
+ - o2 : middle step is performed with time step equals to dt
+ """
+ raise ValueError("Splitting became obsolete")
+ NumMethod.__init__(self, name="splitting")
+ ## Operators to split
+ self.function = function
+ ## Splitting at 2nd order.
+ self.splitting = []
+ if config == 'o2_FullHalf':
+ ## Half timestep in all directions
+ [self.splitting.append((i, 0.5)) for i in xrange(dim)]
+ [self.splitting.append((dim - 1 - i, 0.5)) for i in xrange(dim)]
+ elif config == 'o2':
+ ## Half timestep in all directions but last
+ [self.splitting.append((i, 0.5)) for i in xrange(dim - 1)]
+ self.splitting.append((dim - 1, 1.))
+ [self.splitting.append((dim - 2 - i, 0.5))
+ for i in xrange(dim - 1)]
+ elif config == 'o1':
+ [self.splitting.append((i, 1.)) for i in xrange(dim)]
+ elif config == 'x_only':
+ self.splitting.append((0, 1.))
+ elif config == 'y_only':
+ self.splitting.append((1, 1.))
+ elif config == 'z_only':
+ self.splitting.append((2, 1.))
+ else:
+ ## Full timestep in all directions
+ [self.splitting.append((i, 1.)) for i in xrange(dim)]
+
+ def __call__(self, t, dt):
+ """
+ Apply Remeshing operator.
+
+ @param t : current time.
+ @param dt : time step.
+ """
+ for split_id, split in enumerate(self.splitting):
+ print "direction : " + str(split[0]) +\
+ " dt*" + str(split[1]) + " id:" + str(split_id)
+ self.function(t, dt * split[1], split[0], split_id)
+
+ def __str__(self):
+ s = "Splitting (DiscreteOperator). Splitting steps : \n"
+ for split in self.splitting:
+ s += "direction : " + str(split[0]) + " dt=" + str(split[1]) + "\n"
+ s += "Concerned operators : \n"
+ for op in self.operators:
+ s += str(op)
+ return s
+
+if __name__ == "__main__":
+ print __doc__
+ print "- Provided class : Splitting"
+ print Splitting.__doc__
diff --git a/HySoP/unusedOrObsolet/synchronizeGhosts.py b/HySoP/unusedOrObsolet/synchronizeGhosts.py
new file mode 100644
index 0000000000000000000000000000000000000000..0eff6764f7709d4d2a2d1e546845794a850854a2
--- /dev/null
+++ b/HySoP/unusedOrObsolet/synchronizeGhosts.py
@@ -0,0 +1,493 @@
+"""
+@file operator/discrete/synchronizeGhosts.py
+
+Update ghost points for some fields defined on a specific topology.
+"""
+from parmepy.constants import debug, ORDER, PARMES_INTEGER, PARMES_REAL
+from parmepy.mpi.main_var import main_comm, main_rank
+from discrete import DiscreteOperator
+from parmepy.tools.timers import timed_function
+import numpy as np
+
+
+class SynchronizeGhosts_d(DiscreteOperator):
+ """
+ Ghost points synchronization.
+ """
+
+ @debug
+ def __init__(self, fieldslist, topology, transferMethod='greaterSend'):
+ """
+ Defines a way to send/recv values at ghosts points for a list
+ of fields, discretized on a given topology.
+
+ @param fieldslist : a list of fields
+ @param topology : the topology common to all fields.
+ @param transferMethod : which type of exchange is used.
+ """
+ DiscreteOperator.__init__(self, fieldslist, method=transferMethod,
+ name="Ghosts Synchronization")
+ self.input = fieldslist
+ self.output = fieldslist
+ self.compute_time = 0.
+ self.fieldslist = fieldslist
+ self.topology = topology
+ if (main_rank == 0):
+ print 'CUT SPACE', self.topology.dims
+ self.transferMethod = transferMethod
+
+ @debug
+ def setUp(self):
+
+ self.topoMPI = \
+ self.topology.comm.Create_cart(
+ self.topology.dims,
+ periods=self.topology.periods)
+ ghosts = self.topology.ghosts
+ resolution = self.topology.mesh.resolution
+ self.fieldslist = np.asarray([self.fieldslist])
+ if (self.transferMethod == 'SendRecv'):
+ # Allocation of space for reciev data
+ self.dataRecvX = np.zeros((
+ ghosts[0], resolution[1], resolution[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ self.dataRecvY = np.zeros((
+ resolution[0], ghosts[1], resolution[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ self.dataRecvZ = np.zeros((
+ resolution[0], resolution[1], ghosts[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ self.SendRecvList = np.zeros(
+ self.topology.dim * 2,
+ order=ORDER, dtype=PARMES_INTEGER)
+ self.SendRecvList[0], self.SendRecvList[1] = \
+ self.topology.Shift(0, 1)
+ self.SendRecvList[2], self.SendRecvList[3] = \
+ self.topology.Shift(1, 1)
+ if (self.topology.dim > 2):
+ self.SendRecvList[4], self.SendRecvList[5] = \
+ self.topology.Shift(2, 1)
+
+ if (self.transferMethod == 'greaterSend'):
+ tab = self.topology.neighbours
+ self.tabSort = np.zeros(
+ [self.topology.dim * 2, 2],
+ order=ORDER, dtype=PARMES_INTEGER)
+ self.tabSort[:, 1] = range(self.topology.dim * 2)
+ self.tabSort[0, 0] = tab[0, 0]
+ self.tabSort[1, 0] = tab[1, 0]
+ self.tabSort[2, 0] = tab[0, 1]
+ self.tabSort[3, 0] = tab[1, 1]
+ if(self.topology.dim > 2):
+ self.tabSort[4, 0] = tab[0, 2]
+ self.tabSort[5, 0] = tab[1, 2]
+ tabSort1 = self.tabSort[self.tabSort[:, 0] <= main_rank]
+ tabSort2 = self.tabSort[self.tabSort[:, 0] > main_rank]
+ if (np.asarray(tabSort1[:, 0].shape) > 0):
+ tabSort1 = tabSort1[tabSort1[:, 0].argsort()]
+ if (np.asarray(tabSort2[:, 0].shape) > 0):
+ tabSort2 = tabSort2[tabSort2[:, 0].argsort()]
+ tabSort2 = self.TabInvSort(tabSort2)
+ self.tabSort = np.concatenate((tabSort1, tabSort2))
+
+ if ((self.transferMethod == 'greaterSend') or
+ (self.transferMethod == 'SendRecv')):
+ # Allocation of space for send and reciev data
+ self.dataSendX = np.zeros((
+ ghosts[0], resolution[1], resolution[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ self.dataSendY = np.zeros((
+ resolution[0], ghosts[1], resolution[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ self.dataSendZ = np.zeros((
+ resolution[0], resolution[1], ghosts[2]),
+ dtype=PARMES_REAL, order=ORDER)
+ # 1 - get discrete fields arrays
+ # 2 - get list of ghosts area
+ # 3 - get neighbours
+ # 4 - find what is to be send/recv, the size of the arrays and
+ # allocate buffers if required
+ # 5 - set send/recv order
+ #self.discreteOperator.setUp()
+
+ @debug
+ @timed_function
+ def apply(self, simulation=None):
+ self.resolution = self.topology.mesh.resolution
+ resolution = self.topology.mesh.resolution
+ ghosts = self.topology.ghosts
+ dim = self.topology.dim
+ # Do the send/recv as defined in setup.
+ #### if args is None: \todo : A verifier.
+# args = self.fieldslist
+# self.fieldslist = np.asarray([self.fieldslist])
+ if (self.transferMethod == 'SendRecv'):
+ for f in fieldslist:
+ # DOWN
+ if (main_rank != self.SendRecvList[0]):
+ self.dataSendZ = f[j][:, :, ghosts[2]:2. * ghosts[2]]
+ main_comm.Sendrecv(
+ self.dataSendZ,
+ dest=self.SendRecvList[0],
+ sendtag=22,
+ recvbuf=self.dataRecvZ,
+ source=main_rank,
+ recvtag=11, status=None)
+ f[j][:, :, resolution[2] - ghosts[2]: resolution[2]] = \
+ self.dataRecvZ
+ else:
+ f[j][:, :, resolution[2] - ghosts[2]: resolution[2]
+ ] = f[j][:, :, ghosts[2]:2 * ghosts[2]]
+ # UP
+ if (main_rank != self.SendRecvList[1]):
+ self.dataSendZ = np.array(np.copy(f[j][
+ :, :,
+ resolution[2] - ghosts[2]:resolution[2]],
+ order=ORDER, dtype=PARMES_REAL))
+ main_comm.Sendrecv(
+ self.dataSendZ,
+ dest=self.SendRecvList[1],
+ sendtag=11,
+ recvbuf=self.dataRecvZ,
+ source=main_rank,
+ recvtag=22, status=None)
+ else:
+ f[j][:, :, ghosts[2]:2 * ghosts[2]
+ ] = \
+ f[j][:, :, resolution[2] - ghosts[2]:resolution[2]]
+ # SOUTH
+ if (main_rank != self.SendRecvList[2]):
+ self.dataSendY = f[j][:, ghosts[1]:2. * ghosts[1], :]
+ main_comm.Sendrecv(
+ self.dataSendY,
+ dest=self.SendRecvList[2],
+ sendtag=44,
+ recvbuf=self.dataRecvY,
+ source=main_rank,
+ recvtag=33, status=None)
+ f[j][:, resolution[2] - ghosts[2]:resolution[2], :] \
+ = self.dataRecvY
+ else:
+ f[j][:, resolution[1] - ghosts[1]:resolution[1], :
+ ] = f[j][:, ghosts[1]:2 * ghosts[1], :]
+ # NORTH
+ if (main_rank != self.SendRecvList[3]):
+ self.dataSendY = np.array(np.copy(f[j][
+ :,
+ resolution[1] - ghosts[1]:resolution[1],
+ :],
+ order=ORDER, dtype=PARMES_REAL))
+ main_comm.Sendrecv(
+ self.dataSendY,
+ dest=self.SendRecvList[3],
+ sendtag=33,
+ recvbuf=self.dataRecvY,
+ source=main_rank,
+ recvtag=44, status=None)
+ else:
+ f[j][:, ghosts[1]:2 * ghosts[1], :] =\
+ f[j][:, resolution[1] - ghosts[1]:resolution[1], :]
+ # EAST
+ if (main_rank != self.SendRecvList[4]):
+ self.dataSendX = f[j][ghosts[0]:2. * ghosts[0], :, :]
+ main_comm.Sendrecv(
+ self.dataSendX,
+ dest=self.SendRecvList[4],
+ sendtag=66,
+ recvbuf=self.dataRecvX,
+ source=main_rank,
+ recvtag=55, status=None)
+ f[j][resolution[0] - ghosts[0]:resolution[0], :, :] \
+ = self.dataRecvX
+ else:
+ f[j][resolution[0] - ghosts[0]:resolution[0], :, :
+ ] = f[j][:, :, ghosts[2]:2 * ghosts[2]]
+ # WEST
+ if (main_rank != self.SendRecvList[5]):
+ self.dataSendX = np.array(np.copy(f[j][
+ resolution[0] - ghosts[0]:resolution[0],
+ :, :],
+ order=ORDER, dtype=PARMES_REAL))
+ main_comm.Sendrecv(
+ self.dataSendX,
+ dest=self.SendRecvList[5],
+ sendtag=55,
+ recvbuf=self.dataRecvX,
+ source=main_rank,
+ recvtag=66, status=None)
+ else:
+ f[j][ghosts[0]:2 * ghosts[0], :, :] =\
+ f[j][resolution[0] - ghosts[0]:resolution[0], :, :]
+
+ if (self.transferMethod == 'greaterSend'):
+ for f in self.fieldslist:
+# print 'tabsort', main_rank, self.tabSort
+ for i in xrange(self.tabSort[:, 0].shape[0]):
+# print 'Cours', main_rank, self.tabSort[i, :]
+ if (main_rank == self.tabSort[i, 0]):
+ ## Without communication
+ # WEST
+ if (self.tabSort[i, 1] == 0):
+ for j in xrange(dim):
+ #print '\nTEST', resolution, f[j][...].shape, '\t' , ghosts
+ f[j][resolution[0] - ghosts[0]: resolution[0],
+ :, :] =\
+ f[j][ghosts[0]:2 * ghosts[0], :, :]
+ # EAST
+ if (self.tabSort[i, 1] == 1):
+ for j in xrange(dim):
+ f[j][0:ghosts[0], :, :] =\
+ f[j][
+ resolution[0] - 2 *
+ ghosts[0]:resolution[0] - ghosts[0],
+ :, :]
+
+ # SOUTH
+ if (self.tabSort[i, 1] == 2):
+ for j in xrange(dim):
+ f[j][:, resolution[1] -
+ ghosts[1]:resolution[1], :] =\
+ f[j][:, ghosts[1]:2 * ghosts[1], :]
+ #NORTH
+ if(self.tabSort[i, 1] == 3):
+ for j in xrange(dim):
+ f[j][:, 0:ghosts[1], :] =\
+ f[j][
+ :,
+ resolution[1] - 2 *
+ ghosts[1]:resolution[1] - ghosts[1],
+ :]
+
+ # DOWN
+ if(self.tabSort[i, 1] == 4):
+ for j in xrange(dim):
+ f[j][:, :, resolution[2] -
+ ghosts[2]:resolution[2]] =\
+ f[j][:, :, ghosts[2]:2 * ghosts[2]]
+ # UP
+ if(self.tabSort[i, 1] == 5):
+ for j in xrange(dim):
+ f[j][:, :, 0:ghosts[2]] =\
+ f[j][
+ :, :,
+ resolution[2] - 2 *
+ ghosts[2]:resolution[2] - ghosts[2]]
+# print 'ok', main_rank, self.tabSort[i, :]
+ else:
+ ### PART COMMUNICATION
+ # WEST
+ if(self.tabSort[i, 1] == 0):
+ if (main_rank < self.tabSort[i, 0]):
+ self.WESTsend(self.tabSort[i, 0], f)
+ else:
+ self.WESTrecv(self.tabSort[i, 0], f)
+ # EST
+ if (self.tabSort[i, 1] == 1):
+ if (main_rank < self.tabSort[i, 0]):
+ self.EASTsend(self.tabSort[i, 0], f)
+ else:
+ self.EASTrecv(self.tabSort[i, 0], f)
+ # SOUTH
+ if(self.tabSort[i, 1] == 2):
+ if (main_rank < self.tabSort[i, 0]):
+ self.SOUTHsend(self.tabSort[i, 0], f)
+ else:
+ self.SOUTHrecv(self.tabSort[i, 0], f)
+ # NORTH
+ if (self.tabSort[i, 1] == 3):
+ if (main_rank < self.tabSort[i, 0]):
+ self.NORTHsend(self.tabSort[i, 0], f)
+ else:
+ self.NORTHrecv(self.tabSort[i, 0], f)
+ # DOWN
+ if (self.tabSort[i, 1] == 4):
+ if (main_rank < self.tabSort[i, 0]):
+ self.DOWNsend(self.tabSort[i, 0], f)
+ else:
+ self.DOWNrecv(self.tabSort[i, 0], f)
+ # UP
+ if (self.tabSort[i, 1] == 5):
+ if (main_rank < self.tabSort[i, 0]):
+ self.UPsend(self.tabSort[i, 0], f)
+ else:
+ self.UPrecv(self.tabSort[i, 0], f)
+# print 'ok', main_rank, self.tabSort[i, :]
+# return self.discreteOperator.apply(*args)
+
+ def TabInvSort(self, tab):
+ tmp = tab[0, 0]
+ deb = 0
+ tabcont = 0
+ tabfinal = np.copy(tab)
+ if tab[:, 0].shape[0] == 1:
+ return tab
+ for i in xrange(1, tab[:, 0].shape[0]):
+ if tmp == tab[i, 0]:
+ tabcont = tabcont + 1
+ else:
+ tmp = tab[i, 0]
+ if tabcont == 0:
+ tabfinal[deb, :] = tab[deb, :]
+ else:
+ tabNew = tab[deb:i, :]
+# for l in xrange(int(tabNew[:,1].shape[0] / 2)):
+# tmp = tabNew[2 * l, 1]
+# tabNew[2 * l, 1] = tabNew[2 * l + 1,1]
+# tabNew[2 * l + 1, 1] = tmp
+ tabNew = tabNew[np.invert(tabNew[:, 1].argsort())]
+ tabfinal[deb:i, :] = tabNew
+ deb = i
+ tabcont = 0
+ if deb == tab[:, 0].shape[0]:
+ tabfinal[deb, :] = tab[deb, :]
+ if tabcont > 0:
+ tabNew = tab[deb:tab[:, 0].shape[0], :]
+ tabNew = tabNew[np.invert(tabNew[:, 1].argsort())]
+ tabfinal[deb:tab[:, 0].shape[0], :] = tabNew
+ return tabfinal
+
+ def WESTsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendX = np.array(np.copy(listFields[i][
+ ghosts[0]:ghosts[0] * 2, :, :]), order=ORDER)
+ main_comm.Ssend(self.dataSendX, dest=proc, tag=66)
+ main_comm.Recv(self.dataSendX, source=proc, tag=55)
+ listFields[i][0:ghosts[0], :, :] = self.dataSendX
+
+ def EASTsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendX = np.array(np.copy(listFields[i][
+ resolution[0] - 2 * ghosts[0]:resolution[0] - ghosts[0],
+ :, :]),
+ order=ORDER)
+ main_comm.Ssend(self.dataSendX, dest=proc, tag=66)
+ main_comm.Recv(self.dataSendX, source=proc, tag=55)
+ listFields[i][resolution[0] - ghosts[0]:resolution[0], :, :] =\
+ self.dataSendX
+
+ def SOUTHsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendY = np.array(np.copy(listFields[i][
+ :, ghosts[1]:2 * ghosts[1], :]), order=ORDER)
+ main_comm.Ssend(self.dataSendY, dest=proc, tag=44)
+ main_comm.Recv(self.dataSendY, source=proc, tag=33)
+ listFields[i][:, 0:ghosts[1], :] = self.dataSendY
+
+ def NORTHsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendY = np.array(np.copy(listFields[i][
+ :,
+ resolution[1] - 2 * ghosts[1]:resolution[1] - ghosts[1], :]),
+ order=ORDER)
+ main_comm.Ssend(self.dataSendY, dest=proc, tag=33)
+ main_comm.Recv(self.dataSendY, source=proc, tag=44)
+ listFields[i][:, resolution[1] - ghosts[1]:resolution[1], :] =\
+ self.dataSendY
+
+ def DOWNsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendZ = np.array(np.copy(listFields[i][
+ :, :, ghosts[2]:2 * ghosts[2]]), order=ORDER)
+ main_comm.Ssend(self.dataSendZ, dest=proc, tag=11)
+ main_comm.Recv(self.dataSendZ, source=proc, tag=22)
+ listFields[i][:, :, 0:ghosts[2]] = self.dataSendZ
+
+ def UPsend(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ self.dataSendZ = np.array(np.copy(listFields[i][
+ :, :,
+ resolution[2] - 2 * ghosts[2]:resolution[2] - ghosts[2]
+ ]), order=ORDER)
+ main_comm.Ssend(self.dataSendZ, dest=proc, tag=22)
+ main_comm.Recv(self.dataSendZ, source=proc, tag=11)
+ listFields[i][
+ :, :,
+ resolution[2] - ghosts[2]:resolution[2]] =\
+ self.dataSendZ
+
+ def WESTrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendX, source=proc, tag=66)
+ listFields[i][0:ghosts[0], :, :] = self.dataSendX
+ self.dataSendX = np.array(np.copy(listFields[i][
+ ghosts[0]:2 * ghosts[0], :, :]), order=ORDER)
+ main_comm.Ssend(self.dataSendX, dest=proc, tag=55)
+
+ def EASTrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendX, source=proc, tag=66)
+ listFields[i][resolution[0] - ghosts[0]:resolution[0], :, :] =\
+ self.dataSendX
+ self.dataSendX = np.array(np.copy(listFields[i][
+ resolution[0] - 2 * ghosts[0]:resolution[0] - ghosts[0],
+ :, :]),
+ order=ORDER)
+ main_comm.Ssend(self.dataSendX, dest=proc, tag=55)
+
+ def SOUTHrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendY, source=proc, tag=33)
+ listFields[i][:, 0:ghosts[1], :] = self.dataSendY
+ self.dataSendY = np.array(np.copy(listFields[i][
+ :, ghosts[1]:2 * ghosts[1], :]), order=ORDER)
+ main_comm.Ssend(self.dataSendY, dest=proc, tag=44)
+
+ def NORTHrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendY, source=proc, tag=44)
+ listFields[i][:, resolution[1] - ghosts[1]:resolution[1], :] =\
+ self.dataSendY
+ self.dataSendY = np.array(np.copy(listFields[i][
+ :, resolution[1] - 2 * ghosts[1]:resolution[1] -
+ ghosts[1], :]),
+ order=ORDER)
+ main_comm.Ssend(self.dataSendY, dest=proc, tag=33)
+
+ def DOWNrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendZ, source=proc, tag=22)
+ listFields[i][:, :, 0:ghosts[2]] = self.dataSendZ
+ data = np.array(np.copy(listFields[i][
+ :, :, ghosts[2]:ghosts[2] * 2]), order=ORDER)
+ main_comm.Ssend(self.dataSendZ, dest=proc, tag=11)
+
+ def UPrecv(self, proc, listFields):
+ ghosts = self.topology.ghosts
+ resolution = self.resolution
+ for i in xrange(self.topology.dim):
+ main_comm.Recv(self.dataSendZ, source=proc, tag=11)
+ listFields[i][:, :, resolution[2] - ghosts[2]:resolution[2]] =\
+ self.dataSendZ
+ self.dataSendZ = np.array(np.copy(listFields[i][
+ :, :,
+ resolution[2] - 2 * ghosts[2]:resolution[2] - ghosts[2]
+ ]), order=ORDER)
+ main_comm.Ssend(self.dataSendZ, dest=proc, tag=22)
+
+
+if (__name__ == "__main__"):
+ print __doc__
+ print "- Provided class : SynchronizeGhosts"
+ print SynchronizeGhosts_d.__doc__
diff --git a/HySoP/unusedOrObsolet/test_cpu_data_tranfert.py b/HySoP/unusedOrObsolet/test_cpu_data_tranfert.py
new file mode 100755
index 0000000000000000000000000000000000000000..991ffeb8b460fcf6c9c84f99f8da72f967805c6c
--- /dev/null
+++ b/HySoP/unusedOrObsolet/test_cpu_data_tranfert.py
@@ -0,0 +1,93 @@
+# -*- coding: utf-8 -*-
+import time
+import parmepy as pp
+import numpy as np
+from parmepy.tools.cpu_data_transfer import Synchronize
+from parmepy.tools.printer import Printer
+from math import *
+import unittest
+
+
+
+class test_Cpu_data_transfert(unittest.TestCase):
+ """
+ DiscreteVariable test class
+ """
+
+ def vitesse(self,x, y, z):
+ vx = x
+ vy = y
+ vz = z
+ return vx, vy, vz
+
+
+ def analyticalDivProduct(self, x, y, z):
+ sx = np.cos(x)
+ sy = np.cos(y)
+ sz = np.cos(z)
+ return sx, sy, sz
+
+ def setUp(self):
+ nb = 32.
+ # Parameters
+ self.finalTime = 0.09
+ self.t = 0.
+ self.e = 0.002 # Accepted error between result and analytical result
+ self.dim = 3
+ self.boxLength = [1., 1., 1.]
+ self.boxMin = [ 0., 0., 0.]
+ self.nbPts = [nb, nb, nb]
+ self.timeStep = 0.02
+ self.comm = main_comm
+ self.outputFilePrefix0 = './parmepy/test/test_tools/INIT_'
+ self.outputFilePrefix = './parmepy/test/test_tools/Trans_'
+ ## Domain
+ self.box = pp.Box(dimension=self.dim,
+ length=self.boxLength,
+ origin=self.boxMin)
+
+ def testOperatorSynchronize(self):
+ t0 = time.time()
+
+ ## Fields
+ velo = pp.AnalyticalField(domain=self.box, formula=self.vitesse, name='Velocity', vector=True)
+
+ ## Solver creation (discretisation of objects is done in solver initialisation)
+ topo3D = pp.CartesianTopology(domain=self.box, resolution=self.nbPts, dim=self.dim, periods=[True,True,True] ,ghosts=[2.,2.,2.])
+
+
+# self.anal=np.asarray(np.vectorize(self.analyticalDivProduct)(self.topo3D.mesh.coords[0], \
+# self.topo3D.mesh.coords[1], \
+# self.topo3D.mesh.coords[2]))
+
+ OpSynchronize = Synchronize(topo3D)
+ ## Discretization
+ velo.discretize(topo3D)
+ velo.initialize()
+ t1 = time.time()
+# print 'rank', topo3D.rank, 'tab', topo3D.tabSort
+ io = Printer(fields=[velo], frequency=1, outputPrefix=self.outputFilePrefix0+str(topo3D.rank))
+# io.step()
+ OpSynchronize.apply(velo.discreteField[0])
+ io = Printer(fields=[velo], frequency=1, outputPrefix=self.outputFilePrefix+str(topo3D.rank))
+ io.step()
+
+ tf = time.time()
+# print 'velo :', velo.discreteField[0].data[0][:,0,0],velo.discreteField[0].data[0][:,1,1]
+
+ print "\n"
+ print "Total time : ", tf - t0, "sec (CPU)"
+ print "Init time : ", t1 - t0, "sec (CPU)"
+ print "Solving time : ", tf - t1, "sec (CPU)"
+
+
+ def runTest(self):
+ self.testOperatorSynchronize()
+
+def suite():
+ suite = unittest.TestSuite()
+ suite.addTest(unittest.makeSuite(test_Cpu_data_transfert))
+ return suite
+
+if __name__ == "__main__":
+ unittest.TextTestRunner(verbosity=2).run(suite())
diff --git a/README b/README
new file mode 100644
index 0000000000000000000000000000000000000000..a9760ebc52fc82ae736418db90f7ea24afe44a5e
--- /dev/null
+++ b/README
@@ -0,0 +1,10 @@
+FFTPAR02COR : code Guillaume, version 17/20/2011
+
+Remesh/
+Split2d, Split3d : code d'Adrien
+4GB, FFTPAR : morceaux de code de GH et Guillaume, Ã trier.
+
+NavierStokes3D-Penalization : code d'Adrien
+
+
+
diff --git a/SandBox/ppm_interface/README b/SandBox/ppm_interface/README
new file mode 100644
index 0000000000000000000000000000000000000000..8efc64d02a30391495bdcf275f712d6c03afc32f
--- /dev/null
+++ b/SandBox/ppm_interface/README
@@ -0,0 +1,28 @@
+To create ppm interface ...
+
+
+1 - Create signature file :
+
+f2py -h interf2ppm.pyf -m interf2ppm interf2ppm.f95
+
+2 - edit (optional ...) the generated pyf file
+
+3 - f2py --fcompiler=gfortran -m interf2ppm interf2ppm.pyf interf2ppm.f95 -c -I/home/perignon/install/ppm-core/include/Modules/ -I/usr/lib/openmpi/lib -L/home/perignon/install/ppm-core/lib -lppm_core -L/usr/lib/openmpi/lib -lmpi_f90 -lmpi_f77 -lmpi -lopen-rte -lopen-pal -ldl -I/usr/lib/openmpi/include
+
+
+Dans python
+
+import interf2ppm
+import mpi4py.MPI as mpi
+print interf2ppm.interf2ppm.init.__doc__
+print interf2ppm.interf2ppm.finalize.__doc__
+
+interf2ppm.interf2ppm.init(debug=2)
+
+info = interf2ppm.interf2ppm.finalize()
+
+ou en ligne de commande:
+
+mpirun -np 2 python runPPM.py
+
+
diff --git a/SandBox/ppm_interface/interf2ppm.f95 b/SandBox/ppm_interface/interf2ppm.f95
new file mode 100644
index 0000000000000000000000000000000000000000..d7593611f137e9331e60747a641b7f190d4310bb
--- /dev/null
+++ b/SandBox/ppm_interface/interf2ppm.f95
@@ -0,0 +1,33 @@
+module interf2ppm
+
+ use ppm_module_init
+ use ppm_module_finalize
+ use ppm_module_data
+ use mpi
+
+ implicit none
+
+contains
+
+ subroutine init(dime,prec,tol,debug)
+
+ integer, intent(in) :: dime
+ integer, intent(in) :: prec
+ integer, intent(in) :: tol
+ integer, intent(in) :: debug
+
+ integer :: info, comm
+ comm = MPI_COMM_WORLD
+
+ call ppm_init(dime,prec,tol,comm,debug,info)
+
+ end subroutine init
+
+ subroutine finalize(info)
+ integer, intent(out) :: info
+
+ call ppm_finalize(info)
+
+ end subroutine finalize
+
+end module interf2ppm
diff --git a/SandBox/ppm_interface/interf2ppm.pyf b/SandBox/ppm_interface/interf2ppm.pyf
new file mode 100644
index 0000000000000000000000000000000000000000..a388a14b5ec79893378677f3994174f13a1b8fb1
--- /dev/null
+++ b/SandBox/ppm_interface/interf2ppm.pyf
@@ -0,0 +1,26 @@
+! -*- f90 -*-
+! Note: the context of this file is case sensitive.
+
+python module interf2ppm ! in
+ interface ! in :interf2ppm
+ module interf2ppm ! in :interf2ppm:interf2ppm.f95
+ use ppm_module_data
+ use ppm_module_
+finalize
+ use ppm_module_init
+ use mpi
+ subroutine init(dime,prec,tol,debug) ! in :interf2ppm:interf2ppm.f95:interf2ppm
+ integer optional :: dime = 3
+ integer optional :: prec = 8
+ integer optional :: tol = -10
+ integer optional :: debug = 0
+ end subroutine init
+ subroutine finalize(info) ! in :interf2ppm:interf2ppm.f95:interf2ppm
+ integer intent(out) :: info
+ end subroutine finalize
+ end module interf2ppm
+ end interface
+end python module interf2ppm
+
+! This file was auto-generated with f2py (version:2).
+! See http://cens.ioc.ee/projects/f2py2e/
diff --git a/SandBox/ppm_interface/interf2ppm.pyf.modif b/SandBox/ppm_interface/interf2ppm.pyf.modif
new file mode 100644
index 0000000000000000000000000000000000000000..a388a14b5ec79893378677f3994174f13a1b8fb1
--- /dev/null
+++ b/SandBox/ppm_interface/interf2ppm.pyf.modif
@@ -0,0 +1,26 @@
+! -*- f90 -*-
+! Note: the context of this file is case sensitive.
+
+python module interf2ppm ! in
+ interface ! in :interf2ppm
+ module interf2ppm ! in :interf2ppm:interf2ppm.f95
+ use ppm_module_data
+ use ppm_module_
+finalize
+ use ppm_module_init
+ use mpi
+ subroutine init(dime,prec,tol,debug) ! in :interf2ppm:interf2ppm.f95:interf2ppm
+ integer optional :: dime = 3
+ integer optional :: prec = 8
+ integer optional :: tol = -10
+ integer optional :: debug = 0
+ end subroutine init
+ subroutine finalize(info) ! in :interf2ppm:interf2ppm.f95:interf2ppm
+ integer intent(out) :: info
+ end subroutine finalize
+ end module interf2ppm
+ end interface
+end python module interf2ppm
+
+! This file was auto-generated with f2py (version:2).
+! See http://cens.ioc.ee/projects/f2py2e/
diff --git a/SandBox/ppm_interface/runPPM.py b/SandBox/ppm_interface/runPPM.py
new file mode 100644
index 0000000000000000000000000000000000000000..a5394474d73c9024a0e6599a3626d3f469dc2284
--- /dev/null
+++ b/SandBox/ppm_interface/runPPM.py
@@ -0,0 +1,9 @@
+import interf2ppm
+import mpi4py.MPI as mpi
+
+print interf2ppm.interf2ppm.init.__doc__
+print interf2ppm.interf2ppm.finalize.__doc__
+
+interf2ppm.interf2ppm.init(debug=2)
+
+info = interf2ppm.interf2ppm.finalize()
diff --git a/SandBox/src/Mesh.hpp b/SandBox/src/Mesh.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..4fc1107e9cc8a9b73660682cf9bb63c679fc7755
--- /dev/null
+++ b/SandBox/src/Mesh.hpp
@@ -0,0 +1,47 @@
+#ifndef MESHHPP
+#define MESHHPP
+#include<iostream>
+class Mesh {
+
+public :
+ Mesh(int *a, int *b, int *c,double*d)
+ {
+ nx = *a;
+ ny = *b;
+ nz = *c;
+ *geometry = *d;
+ grid = new double(nx*ny*nz);
+ for (int i = 0; i <nx*ny*nz ; ++i)
+ {
+ grid[i] = i*2.5;
+ std::cout << grid[i] << " " ;
+ }
+ std::cout << std::endl;
+ std::cout << "Constr Mesh " << std::endl;
+
+ }
+
+ Mesh(double*d)
+ {
+ *geometry = *d;
+ std::cout << "Constr Mesh " << std::endl;
+
+ }
+
+
+ ~Mesh(){std::cout<< "del Mesh " << std::endl;}
+
+ double *getGrid() const {return grid;}
+ int getSizeX() const {return nx;}
+ int getSizeY() const{return ny;}
+ int getSizeZ() const{return nz;}
+
+private:
+
+ double * grid;
+ int nx, ny, nz;
+ double geometry[4];
+};
+
+#endif
+
diff --git a/SandBox/src/MeshModule.f90 b/SandBox/src/MeshModule.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b73d2c75f76f674ca1cc0af8cc3e70899c97a738
--- /dev/null
+++ b/SandBox/src/MeshModule.f90
@@ -0,0 +1,68 @@
+MODULE MeshModule
+
+ implicit none
+
+
+ PUBLIC initMesh, initMesh2, getGrid, deleteMesh, aliasGrid, getPtr, alias
+ PRIVATE
+
+ INTEGER :: nx, ny, nz
+ REAL*8, pointer :: grid(:,:,:)
+ real(kind =8), pointer :: fptr(:)
+
+CONTAINS
+
+ SUBROUTINE initMesh(L,M,N,g)
+ INTEGER :: L,M,N
+ REAL*8 :: g(4)
+ CALL cinitmesh(L,M,N,g)
+ end SUBROUTINE initMesh
+
+ SUBROUTINE initMesh2(L,M,N,g)
+ INTEGER :: L,M,N
+ REAL*8 :: g(4)
+ CALL cinitmesh(g)
+ end SUBROUTINE initMesh2
+
+ SUBROUTINE aliasGrid(n1,n2,n3,a)
+ INTEGER :: n1,n2,n3
+ REAL*8, TARGET :: a(n1,n2,n3)
+ nx = n1
+ ny = n2
+ ny = n3
+ print *, 'alias ... ', a(2,1,1)
+ grid => a(1:nx,1:ny,1:nz)
+ print *, grid(2,1,1)
+ print *, 'end alias '
+ end SUBROUTINE aliasGrid
+
+ SUBROUTINE alias(n1,a)
+ INTEGER :: n1
+ REAL(kind=8), TARGET :: a(n1)
+ nx = n1
+ print *, 'alias ... '
+ fptr => a(1:nx)
+ print *, 'end alias '
+ end SUBROUTINE alias
+
+ SUBROUTINE deleteMesh()
+ CALL cdeleteMesh()
+ END SUBROUTINE deleteMesh
+
+
+ FUNCTION getGrid() result(p)
+ REAL*8, POINTER :: p(:,:,:)
+ CALL cgetGrid()
+ p => grid(1:nx,1:ny,1:nz)
+ end FUNCTION getGrid
+
+ function getPtr() result(p)
+ real(kind=8), pointer :: p(:)
+ call cgetptr()
+ p=>fptr(1:nx)
+ end function getPtr
+
+
+
+
+end MODULE MeshModule
diff --git a/SandBox/src/modTest.f90 b/SandBox/src/modTest.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1fecf042e8fc1d3c68995cc2876b75a7a1e8c7e2
--- /dev/null
+++ b/SandBox/src/modTest.f90
@@ -0,0 +1,179 @@
+module modTest
+
+implicit none
+
+contains
+
+ subroutine testglob()
+
+ real(kind=8), dimension(:), pointer :: vec
+ allocate(vec(4))
+ vec = 3.4
+
+ call cas6(vec)
+ print *, ' test ....', vec
+
+ if(associated(vec)) then
+ print *, 'free '
+ deallocate(vec)
+ nullify(vec)
+ end if
+
+ end subroutine testglob
+
+ subroutine cas1(x)
+
+ real*8, dimension(2) :: x
+
+ x(2) = x(2) +1.65
+ print *, 'cas 1', x(1), ' ', x(2)
+
+ end subroutine cas1
+
+ subroutine cas2(x)
+
+ real*8, dimension(*), intent(inout) :: x
+
+
+ print *, 'cas2a', x(1), ' ', x(2)
+
+ x(2) = x(2) +1.65
+ print *, 'cas 2b', x(1), ' ', x(2)
+
+ end subroutine cas2
+
+ subroutine cas3(x)
+
+ real(kind=8), dimension(:), intent(in) :: x
+
+
+ print *, 'cas3a', x(1), ' ', x(2)
+
+ end subroutine cas3
+ subroutine cas4(x)
+
+ real(kind=8), dimension(:), intent(inout) :: x
+
+
+ print *, 'cas3a', x(1), ' ', x(2)
+
+ x(2) = x(2) +1.65
+ print *, 'cas 3b', x(1), ' ', x(2)
+
+ end subroutine cas4
+
+ subroutine cas5(x)
+
+ !! integer, intent(in) :: size
+ real(kind=8), pointer, dimension(:) :: x
+
+ allocate(x(2))
+ x(1) =12
+ x(2) = 8
+ print *, 'cas5a', x(1), ' ', x(2)
+
+ x(2) = 1.65
+ print *, 'cas 5b', x(1), ' ', x(2)
+ print * , x
+ end subroutine cas5
+
+ subroutine cas6(x)
+
+ !! integer, intent(in) :: size
+ real(kind=8), pointer, dimension(:) :: x
+
+ x(1) =12
+ x(2) = 8
+ !print *, 'cas6a', shape(x), ' ', x(1), ' ', x(2)
+
+ x(2) = 1.65
+ print *, 'cas 6b', x(1), ' ', x(2)
+ print * , x
+
+ end subroutine cas6
+
+
+ subroutine Application()
+ USE MeshModule, ONLY : initMesh, getGrid, deleteMesh
+
+ INTEGER :: n1, n2, n3
+ REAL*8 :: geometry(3,3)
+ REAL*8, pointer :: grid(:,:,:)
+ print *, 'start applic ...'
+ READ(*,*)n1, n2, n3, geometry(1:2,1:2)
+ CALL initMesh(n1, n2, n3, geometry)
+
+ grid => getGrid()
+ print *, 'shape ', shape(grid)
+ print *, 'grid : ', grid(2,1,1)
+ print *, 'end appli ...'
+ CALL deleteMesh()
+
+ end subroutine Application
+ subroutine Application2()
+ USE MeshModule, ONLY : initMesh2, getGrid, deleteMesh
+
+ INTEGER :: n1, n2, n3
+ REAL*8 :: geometry(3,3)
+ REAL*8, pointer :: grid(:,:,:)
+ print *, 'start applic2 ...'
+ !!READ(*,*)n1, n2, n3, geometry(1:2,1:2)
+ geometry = 12
+ n1 = 2
+ n2 = 3
+ n3 = 4
+ CALL initMesh2(n1, n2, n3, geometry)
+
+ grid => getGrid()
+ allocate(grid(n1,n2,n3))
+ grid(2,1,1) = 12.4
+ print *, 'shape ', shape(grid)
+ print *, 'grid : ', grid(2,1,1)
+ print *, 'end appli2 ...'
+ CALL deleteMesh()
+
+ end subroutine Application2
+ subroutine Application3()
+ USE MeshModule, ONLY : getPtr, deleteMesh
+
+ INTEGER :: nx
+ REAL(kind=8), pointer :: xp(:)
+ print *, 'start applic3 ...'
+
+ nx = 4
+ xp => getPtr()
+ allocate(xp(nx))
+ xp = 12.4
+ print *, 'shape ', shape(xp)
+ print *, 'xp : ', xp(1:nx)
+ print *, 'end appli3 ...'
+ !! CALL deleteMesh()
+
+ end subroutine Application3
+
+ SUBROUTINE bridge(nx, ny, nz, a)
+ USE MeshModule, only: aliasGrid
+ INTEGER, INTENT(IN) :: nx,ny,nz
+ REAL*8, INTENT(IN) :: a(nx*ny*nz)
+
+ print *, "BRIDGE ", a(2)
+
+ CALL aliasGrid(nx, ny, nz, a)
+
+ print *, 'end bridge'
+ END SUBROUTINE bridge
+
+ SUBROUTINE bridge2(nx, a)
+ USE MeshModule, only: alias
+ INTEGER, INTENT(IN) :: nx
+ REAL*8, INTENT(IN) :: a(nx)
+
+ print *, "BRIDGE 2"
+
+ CALL alias(nx,a)
+
+ print *, 'end bridge2 '
+ END SUBROUTINE bridge2
+
+
+end module modTest
diff --git a/SandBox/src/ppm_wrapper.hpp b/SandBox/src/ppm_wrapper.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..168c56d3577b1b052ca10197ba96b92b93fa558c
--- /dev/null
+++ b/SandBox/src/ppm_wrapper.hpp
@@ -0,0 +1,152 @@
+/** \file ppm_wrapper.hpp Interfaces to ppm (fortran) routines
+ */
+#ifndef PPMWRAPPER_HPP
+#define PPMWRAPPER_HPP
+#include"FCMangle.h"
+#include<mpi.h>
+#include <cstring>
+#include "Mesh.hpp"
+
+/** Namespace for ppm functions and subroutines */
+
+Mesh* p_obj = 0;
+double * globalPtr = 0;
+
+namespace PPM
+{
+
+
+
+
+ extern "C" {
+ // Init and close ppm
+ void PPM_MODULE(ppm_module_init,ppm_init, PPM_MODULE_INIT,PPM_INIT)(int*, int*,int*,int*,int*,int*,int*,int*,int*);
+ void PPM_MODULE(ppm_module_finalize, ppm_finalize,PPM_MODULE_FINALIZE,PPM_FINALIZE)(int&);
+ // Display functions
+ void PPM_MODULE(charfunctions, start, CHARFUNCTIONS, START)(double*,int*,char*,int );
+ void PPM_MODULE(charfunctions, stop, CHARFUNCTIONS, stop)(double*,int*,char*,int );
+
+ void PPM_MODULE(testppm,mult,TESTPPM,MULT)(double*,double*,int*);
+ // Topologies
+ // void PPM_MODULE(ppm_module_mktopo, ppm_mktopo, PPM_MODULE_MKTOPO,PPM_MKTOPO)(int*, double*, int*,
+
+ void PPM_MODULE(modtest, cas1, MODTEST,CAS1)(double*);
+ void PPM_MODULE(modtest, cas2, MODTEST,CAS2)(double*);
+ void PPM_MODULE(modtest, cas3, MODTEST,CAS3)(double*);
+ void PPM_MODULE(modtest, cas4, MODTEST,CAS4)(double*);
+ void PPM_MODULE(modtest, cas5, MODTEST,CAS5)(double*);
+ void PPM_MODULE(modtest, cas6, MODTEST,CAS6)(double**);
+ void PPM_MODULE(modtest, testglob, MODTEST,TESTGLOB)();
+ void PPM_MODULE(modtest, application, MODTEST,APPLICATION)();
+ void PPM_MODULE(modtest, application2, MODTEST,APPLICATION2)();
+ void PPM_MODULE(modtest, application3, MODTEST,APPLICATION3)();
+ void PPM_MODULE(modtest, bridge, MODTEST,BRIDGE)(int*,int*,int*,double*);
+ void PPM_MODULE(modtest, bridge2, MODTEST,BRIDGE2)(int*,double*);
+
+ // int PPM_MODULE(ppm_module_data,ppm_debug, PPM_MODULE_DATA,PPM_DEBUG);
+
+
+
+
+ }
+
+ //#define DEBUG PPM_MODULE_(ppm_module_data,ppm_debug, PPM_MODULE_DATA,PPM_DEBUG)
+
+ /** A static class to call wrapped ppm functions */
+ class wrapper
+ {
+
+ static int _info;
+
+ public :
+
+ /** PPM initialization
+ \param problem dimension
+ \param precision for real numbers
+ \param exp tolerance
+ \param MPI comm
+ \param debug mode value
+ \param error status
+ \param log unit value for io
+ \param stderr unit value
+ \param stdout unit value
+ */
+ static void init(int ndim, int MK,int tolexp, MPI::Intracomm& comm, int debug, int* info, int ppm_log_unit, int err, int out)
+ {
+ MPI_Fint Fcomm = MPI_Comm_c2f(comm);
+ PPM_MODULE(ppm_module_init,ppm_init, PPM_MODULE_INIT,PPM_INIT)(&ndim,&MK,&tolexp,&Fcomm,&debug,info,&ppm_log_unit,&err,&out);
+ }
+
+ /** Terminates ppm library
+ \param[in,out] error status
+ */
+ static void finalize(int& info)
+ {
+ PPM_MODULE(ppm_module_finalize, ppm_finalize,PPM_MODULE_FINALIZE,PPM_FINALIZE)(info);
+ }
+
+ /** Wrapper to ppm substart function
+ @param[in] caller name
+ @param[in,out] cpu time when this function is called
+ @param[in] error status
+ */
+ static void substart(std::string& msg, double* t0, int* info)
+ {
+ size_t size = msg.size()+1;
+ char * msgF = new char[size];
+ strncpy(msgF, msg.c_str(),size);
+ PPM_MODULE(charfunctions, start, CHARFUNCTIONS, START)(t0,info,msgF,strlen(msgF));
+ }
+
+ /** Wrapper to ppm substopt function
+ @param[in] caller name
+ @param[in] cpu time when substart for this function has been called
+ @param[in] error status
+ */
+ static void substop(std::string& msg, double* t0, int* info)
+ {
+ size_t size = msg.size()+1;
+ char * msgF = new char[size];
+ strncpy(msgF, msg.c_str(),size);
+ PPM_MODULE(charfunctions, stop, CHARFUNCTIONS, STOP)(t0,info,msgF,strlen(msgF));
+ }
+
+ };
+
+}
+ extern "C" {
+ void cinitmesh_(int *nx, int *ny, int *nz, double *geom) {
+ p_obj = new Mesh(nx,ny,nz,geom);
+ }
+
+
+ void cdeletemesh_() { delete p_obj; }
+
+ void cgetgrid_() {
+ std::cout << "cgetgrid ..." << std::endl;
+ double *p_mem = p_obj->getGrid();
+ int nx = p_obj->getSizeX();
+ int ny = p_obj->getSizeY();
+ int nz = p_obj->getSizeZ();
+ std::cout << p_mem[1] << std::endl;
+ PPM::PPM_MODULE(modtest, bridge, MODTEST,BRIDGE)(&nx, &ny, &nz, p_mem);
+ p_mem = 0;
+ std::cout << "Fin cgetgrid ..." << std::endl;
+ }
+
+ void cinit_(double* toto)
+ {
+ globalPtr = toto;
+ }
+
+ void cgetptr_() {
+ std::cout << "cgetPtr ..." << std::endl;
+ double *p_mem = globalPtr;
+ int nx = 2;
+ PPM::PPM_MODULE(modtest, bridge2, MODTEST,BRIDGE2)(&nx, p_mem);
+ p_mem = 0;
+ std::cout << "Fin cgetptr ..." << std::endl;
+ }
+ }
+
+#endif
diff --git a/todo.org b/todo.org
index bc29ee25eed8f2d5995f74636fd3317cf2659e48..2dda25cb22f77f8fc6b5086e38ec7091e281de71 100644
--- a/todo.org
+++ b/todo.org
@@ -1,11 +1,4 @@
-=========
-todo list
-=========
-Items should contain a brief description and a date of completion.
-
-* Redistributes MPI tag should depend on variables names. It prevent from mixing simultaneous async messages.
-
-* update/clean this file ...
+Bilan réunion du 15/02/2012
* Tests operations sur tableaux (Franck)
** tests numpy : timer + mémoire
*** operations algebriques linéaires