diff --git a/src/.depend b/src/.depend
index 5676073..7d949a0 100644
--- a/src/.depend
+++ b/src/.depend
@@ -1,34 +1,35 @@
auxval.o : auxval.f90 beam_mod.o fields_mod.o basic_mod.o constants.o
auxval__genmod.o : auxval__genmod.f90
basic_mod.o : basic_mod.f90 mpihelper_mod.o constants.o
-beam_mod.o : beam_mod.f90 basic_mod.o mpihelper_mod.o constants.o
+beam_mod.o : beam_mod.f90 basic_mod.o mpihelper_mod.o constants.o distrib_mod.o
chkrst.o : chkrst.f90 fields_mod.o beam_mod.o basic_mod.o
chkrst__genmod.o : chkrst__genmod.f90
constants.o : constants.f90
cp2bk__genmod.o : cp2bk__genmod.f90
diagnose.o : diagnose.f90 xg_mod.o beam_mod.o basic_mod.o
diagnose__genmod.o : diagnose__genmod.f90
+distrib_mod.o : distrib_mod.f90
endrun.o : endrun.f90 fields_mod.o beam_mod.o basic_mod.o
endrun__genmod.o : endrun__genmod.f90
energies.o : energies.f90 basic_mod.o
fields_mod.o : fields_mod.f90 mpihelper_mod.o beam_mod.o basic_mod.o constants.o
inital.o : inital.f90 mpihelper_mod.o fields_mod.o beam_mod.o basic_mod.o
inital__genmod.o : inital__genmod.f90
main.o : main.f90 basic_mod.o
mpihelper_mod.o : mpihelper_mod.f90 constants.o
mv2bk.o : mv2bk.f90
mv2bk__genmod.o : mv2bk__genmod.f90
newrun.o : newrun.f90
newrun__genmod.o : newrun__genmod.f90
restart.o : restart.f90
restart__genmod.o : restart__genmod.f90
resume.o : resume.f90 sort_mod.o fields_mod.o basic_mod.o beam_mod.o
resume__genmod.o : resume__genmod.f90
sort_mod.o : sort_mod.f90 beam_mod.o
start.o : start.f90 basic_mod.o
start__genmod.o : start__genmod.f90
stepon.o : stepon.f90 beam_mod.o fields_mod.o constants.o basic_mod.o
stepon__genmod.o : stepon__genmod.f90
tesend.o : tesend.f90 basic_mod.o
tesend__genmod.o : tesend__genmod.f90
xg_mod.o : xg_mod.f90 fields_mod.o beam_mod.o basic_mod.o constants.o
diff --git a/src/Makefile b/src/Makefile
index 7fb8dff..e647553 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,78 +1,78 @@
.DEFAULT_GOAL := all
ifeq ($(PLATFORM),)
$(error Please specify the env variable PLATFORM (mac, intel))
else
$(info *** Using $(PLATFORM).mk ***)
include $(PLATFORM).mk
endif
include .depend
PROG = espic2d
SRCS = main.f90 basic_mod.f90 newrun.f90 restart.f90 \
auxval.f90 inital.f90 resume.f90 start.f90 diagnose.f90 \
stepon.f90 tesend.f90 endrun.f90 chkrst.f90 mv2bk.f90 \
constants.f90 xg_mod.f90 fields_mod.f90 beam_mod.f90 \
- mpihelper_mod.f90 sort_mod.f90
+ mpihelper_mod.f90 sort_mod.f90 distrib_mod.f90
SRCS_C = extra.c
MKDIR_P = mkdir -p
OUT_DIR = release
F90FLAGS += -I$(BSPLINES)/include -I$(FUTILS)/include \
-I$(MUMPS)/include -I../src
LDFLAGS += -L$(BSPLINES)/lib -L$(FUTILS)/lib -L${HDF5}/lib -L${HDF5}/lib \
-L$(MUMPS)/lib -L$(PARMETIS)/lib -L/usr/local/xgrafix_1.2/src-double
LIBS += -lbsplines -lpppack -lfutils -lhdf5_fortran -lhdf5 -lz $(MUMPSLIBS) -lpputils2 \
-lXGF -lXGC -lX11
OBJS =${SRCS:.f90=.o} ${SRCS_F90:.F90=.o} ${SRCS_C:.c=.o}
debug: F90FLAGS = $(DEBUGFLAGS) -I$(BSPLINES)/include -I$(FUTILS)/include \
-I$(MUMPS)/include
debug: OUT_DIR=debug
debug: $(OUT_DIR) all
profile: F90FLAGS+=$(PROFILEFLAGS)
profile: LDFLAGS+= $(PROFILEFLAGS)
profile: OUT_DIR=profile
profile: $(OUT_DIR) all
.PHONY: directories
all: directories $(PROG)
$(PROG): $(OBJS)
$(F90) $(LDFLAGS) $(F90FLAGS) -o $@ $(addprefix ./$(OUT_DIR)/,$(OBJS)) $(LIBS)
mv *.mod ./$(OUT_DIR)/
tags:
etags *.f90
clean:
rm -f $(OBJS) *.mod
distclean: clean
rm -f $(PROG) *~ a.out *.o TAGS
directories: ${OUT_DIR}
${OUT_DIR}:
${MKDIR_P} ${OUT_DIR}
.SUFFIXES: $(SUFFIXES) .f90 .c
.f90.o:
$(F90) $(F90FLAGS) -c -o ./$(OUT_DIR)/$@ $<
.c.o:
$(CC) $(CCFLAGS) -c -o ./$(OUT_DIR)/$@ $<
depend .depend:
makedepf90 *.[fF]90 > .depend
diff --git a/src/basic_mod.f90 b/src/basic_mod.f90
index 95f5a44..b35937e 100644
--- a/src/basic_mod.f90
+++ b/src/basic_mod.f90
@@ -1,318 +1,318 @@
MODULE basic
!
USE hashtable
USE constants
USE bsplines
USE mumps_bsplines
USE futils
USE mpihelper
IMPLICIT NONE
!
! Basic module for time dependent problems
!
CHARACTER(len=80) :: label1, label2, label3, label4
!
! BASIC Namelist
!
LOGICAL :: nlres = .FALSE. !< Restart flag
LOGICAL :: nlsave = .TRUE. !< Checkpoint (save) flag
LOGICAL :: newres=.FALSE. !< New result HDF5 file
LOGICAL :: nlxg=.FALSE. !< Show graphical interface Xgrafix
INTEGER :: nrun=1 !< Number of time steps to run
DOUBLE PRECISION :: job_time=3600.0 !< Time allocated to this job in seconds
DOUBLE PRECISION :: tmax=100000.0 !< Maximum simulation time
DOUBLE PRECISION :: extra_time=60.0 !< Extra time allocated
DOUBLE PRECISION :: dt=1 !< Time step
DOUBLE PRECISION :: time=0 !< Current simulation time (Init from restart file)
!
! Other basic global vars and arrays
!
INTEGER :: jobnum !< Job number
INTEGER :: step !< Calculation step of this run
INTEGER :: cstep=0 !< Current step number (Init from restart file)
LOGICAL :: nlend !< Signal end of run
INTEGER :: ierr !< Integer used for MPI
INTEGER :: it0d=1 !< Number of iterations between 0d values writes to hdf5
INTEGER :: it2d=1 !< Number of iterations between 2d values writes to hdf5
INTEGER :: itparts=1 !< Number of iterations between particles values writes to hdf5
INTEGER :: ittext=1 !< Number of iterations between text outputs in the console
INTEGER :: itrestart=10000 !< Number of iterations between save of restart.h5 file
INTEGER :: itgraph !< Number of iterations between graphical interface updates
INTEGER :: mpirank !< MPIrank of the current processus
INTEGER :: mpisize !< Size of the MPI_COMM_WORLD communicator
INTEGER :: rightproc !< Rank of next processor in the z decomposition
INTEGER :: leftproc !< Rank of previous processor in the z decomposition
!
! List of logical file units
INTEGER :: lu_in = 90 !< File duplicated from STDIN
INTEGER :: lu_stop = 91 !< stop file, see subroutine TESEND
!
! HDF5 file
CHARACTER(len=64) :: resfile = "results.h5" !< Main result file
CHARACTER(len=64) :: rstfile = "restart.h5" !< Restart file
INTEGER :: fidres !< File ID for resfile
INTEGER :: fidrst !< File ID for restart file
TYPE(BUFFER_TYPE) :: hbuf0 !< Hashtable for 0d var
!
! Plasma parameters
LOGICAL :: nlPhis= .TRUE. !< Calculate self consistent electric field flag
LOGICAL :: nlclassical= .FALSE. !< If true, solves the equation of motion according to classical
!! dynamics
LOGICAL :: nlperiod(2)=(/.false.,.false./)!< Set periodic splines on or off
LOGICAL :: partperiodic= .TRUE. !< Sets if the particles boundary conditions are periodic or open
INTEGER :: nplasma !< Number of macro-particles
INTEGER :: nblock !< Number of slices in Z for stable distribution initialisation
DOUBLE PRECISION :: potinn !< Electric potential at the inner metallic wall
DOUBLE PRECISION :: potout !< Electric potential at the outer metallic wall
DOUBLE PRECISION :: B0 !< Max magnitude of magnetic field
DOUBLE PRECISION, allocatable :: Bz(:), Br(:) !< Magnetic field components
DOUBLE PRECISION, allocatable :: Athet(:) !< Theta component of the magnetic vector potential
TYPE(spline2d) :: splrz !< Spline at r and z
DOUBLE PRECISION, allocatable :: Ez(:), Er(:) !< Electric field components
DOUBLE PRECISION, allocatable :: pot(:) !< Electro static potential
DOUBLE PRECISION :: radii(4) !< Inner and outer radius of cylinder and radii of fine mesh region
DOUBLE PRECISION :: plasmadim(4) !< Zmin Zmax Rmin Rmax values for plasma particle loading
INTEGER :: distribtype=1 !< Type of distribution function used to load the particles
!!1: gaussian, 2: Stable as defined in 4.95 of Davidson
DOUBLE PRECISION :: H0=0 !< Initial value of Hamiltonian for distribution 2
DOUBLE PRECISION :: P0=0 !< Initial canonical angular momentum for distribution 2
DOUBLE PRECISION :: temprescale = -1.0 !< Factor used for temperature rescaling in case of a restart (<0 -> no rescaling)
INTEGER :: samplefactor =-1 !< Factor used for the up-sampling of the particles number
DOUBLE PRECISION :: lz(2) !< Lower and upper cylinder limits in z direction
DOUBLE PRECISION :: n0 !< Physical plasma density parameter
DOUBLE PRECISION, ASYNCHRONOUS, DIMENSION(:,:), ALLOCATABLE, SAVE:: moments !< Moments of the distribution function evaluated every it2d
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE:: rhs !< right hand side of the poisson equation solver
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE:: volume !< Volume covered by each spline for density calculation
INTEGER :: nz !< Number of grid intervals in z
INTEGER :: nr !< Total number of grid intervals in r
INTEGER :: nnr(3) !< Number of grid intervals in r in each subdomain
DOUBLE PRECISION :: dz !< Cell size in z
DOUBLE PRECISION :: dr(3) !< Cell size in r for each region
DOUBLE PRECISION, ALLOCATABLE :: zgrid(:) !< Nodes positions in longitudinal direction
DOUBLE PRECISION, ALLOCATABLE :: rgrid(:) !< Nodes positions in radial direction
DOUBLE PRECISION :: bnorm,enorm,vnorm,tnorm,rnorm,phinorm !< Normalization constants
DOUBLE PRECISION :: qsim !< Charge of superparticles
DOUBLE PRECISION :: msim !< Mass of superparticles
INTEGER :: femorder(2) !< FEM order
INTEGER :: ngauss(2) !< Number of gauss points
LOGICAL :: nlppform =.TRUE. !< Argument of set_spline
INTEGER, SAVE :: nrank(2) !< Number of splines in both directions
DOUBLE PRECISION :: omegac !< Cyclotronic frequency
DOUBLE PRECISION :: omegap !< Plasma frequency
DOUBLE PRECISION :: V !< Normalised volume
DOUBLE PRECISION :: temp !< Initial temperature of plasma
DOUBLE PRECISION :: Rcurv !< Magnetic field curvature coefficient
DOUBLE PRECISION :: Width !< Distance between two magnetic mirrors
INTEGER, DIMENSION(:), ALLOCATABLE :: Zbounds !< Index of bounds for local processus in Z direction
- TYPE(BASICDATA) :: bdata
+ TYPE(BASICDATA) :: bdata !< Structure used for the mpi communication of the run parameters
CONTAINS
!
!================================================================================
SUBROUTINE basic_data
!
! Define basic data
!
use mpihelper
IMPLICIT NONE
!
! Local vars and arrays
CHARACTER(len=256) :: line, inputfilename
!
NAMELIST /BASIC/ job_time, extra_time, nrun, tmax, dt, nlres, nlsave, newres, nlxg, &
& nplasma, potinn, potout, B0, lz, n0, nz, nnr, femorder, ngauss, &
& nlppform, plasmadim, radii, temp, Rcurv, width, it0d, it2d, itparts, ittext, &
& resfile, rstfile, itgraph, nlPhis, distribtype, nblock, nlclassical, H0, P0, partperiodic, &
& temprescale, samplefactor
!________________________________________________________________________________
! 1. Process Standard Input File
!
IF(mpirank .eq. 0) THEN
IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
WRITE(*,*)'ERROR, ONE COMMAND-LINE ARGUMENT REQUIRED, STOPPING'
STOP
ENDIF
CALL GET_COMMAND_ARGUMENT(1,inputfilename)
OPEN(UNIT=lu_in,FILE=trim(inputfilename))
!________________________________________________________________________________
! 1. Label the run
!
READ(lu_in,'(a)') label1
READ(lu_in,'(a)') label2
READ(lu_in,'(a)') label3
READ(lu_in,'(a)') label4
!
WRITE(*,'(12x,a/)') label1(1:len_trim(label1))
WRITE(*,'(12x,a/)') label2(1:len_trim(label2))
WRITE(*,'(12x,a/)') label3(1:len_trim(label3))
WRITE(*,'(12x,a/)') label4(1:len_trim(label4))
!________________________________________________________________________________
! 2. Read in basic data specific to run
!
READ(lu_in,basic)
WRITE(*,basic)
bdata=BASICDATA( nlres, nlsave, newres, nlxg, nlppform, nlPhis, nlclassical, &
& nplasma, nz, it0d, it2d, itparts, itgraph, distribtype, nblock, &
& nrun, job_time, extra_time, tmax, dt, potinn, potout, B0, n0, temp, &
& Rcurv, width, H0, P0, femorder, ngauss, nnr, lz, radii, plasmadim, resfile, partperiodic, samplefactor)
END IF
! Distribute run parameters to all MPI workers
CALL init_mpitypes ! initialize all mpi types that will be needed in the simulation
CALL MPI_Bcast(bdata, 1, basicdata_type, 0, MPI_COMM_WORLD, ierr)
CALL readbdata
IF(samplefactor .gt. 1 .and. .not. newres) THEN
IF(mpirank.eq.0) WRITE(*,*)"To increase the number of particles, you need to create a new result file (set newres to 1)"
CALL MPI_abort(MPI_COMM_WORLD,-1,ierr)
END IF
!
END SUBROUTINE basic_data
!================================================================================
SUBROUTINE daytim(str)
!
! Print date and time
!
IMPLICIT NONE
!
CHARACTER(len=*), INTENT(in) :: str
!
! Local vars and arrays
CHARACTER(len=16) :: d, t, dat, functime
!________________________________________________________________________________
!
CALL DATE_AND_TIME(d,t)
dat=d(7:8) // '/' // d(5:6) // '/' // d(1:4)
functime=t(1:2) // ':' // t(3:4) // ':' // t(5:10)
WRITE(*,'(a,1x,a,1x,a)') str, dat(1:10), functime(1:12)
!
END SUBROUTINE daytim
!================================================================================
SUBROUTINE timera(cntrl, str, eltime)
!
! Timers (cntrl=0/1 to Init/Update)
!
IMPLICIT NONE
INTEGER, INTENT(in) :: cntrl
CHARACTER(len=*), INTENT(in) :: str
DOUBLE PRECISION, OPTIONAL, INTENT(out) :: eltime
!
INTEGER, PARAMETER :: ncmax=128
INTEGER, SAVE :: icall=0, nc=0
DOUBLE PRECISION, SAVE :: startt0=0.0
CHARACTER(len=16), SAVE :: which(ncmax)
INTEGER :: lstr, found, i
DOUBLE PRECISION :: seconds
DOUBLE PRECISION, DIMENSION(ncmax), SAVE :: startt = 0.0, endt = 0.0
!________________________________________________________________________________
IF( icall .EQ. 0 ) THEN
icall = icall+1
startt0 = seconds()
END IF
lstr = LEN_TRIM(str)
IF( lstr .GT. 0 ) found = loc(str)
!________________________________________________________________________________
!
SELECT CASE (cntrl)
!
CASE(-1) ! Current wall time
IF( PRESENT(eltime) ) THEN
eltime = seconds() - startt0
ELSE
WRITE(*,'(/a,a,1pe10.3/)') "++ ", ' Wall time used so far = ', seconds() - startt0
END IF
!
CASE(0) ! Init Timer
IF( found .EQ. 0 ) THEN ! Called for the 1st time for 'str'
nc = nc+1
which(nc) = str(1:lstr)
found = nc
END IF
startt(found) = seconds()
!
CASE(1) ! Update timer
endt(found) = seconds() - startt(found)
IF( PRESENT(eltime) ) THEN
eltime = endt(found)
ELSE
WRITE(*,'(/a,a,1pe10.3/)') "++ "//str, ' wall clock time = ', endt(found)
END IF
!
CASE(2) ! Update and reset timer
endt(found) = endt(found) + seconds() - startt(found)
startt(found) = seconds()
IF( PRESENT(eltime) ) THEN
eltime = endt(found)
END IF
!
CASE(9) ! Display all timers
IF( nc .GT. 0 ) THEN
WRITE(*,'(a)') "Timer Summary"
WRITE(*,'(a)') "============="
DO i=1,nc
WRITE(*,'(a20,2x,2(1pe12.3))') TRIM(which(i))//":", endt(i)
END DO
END IF
!
END SELECT
!
CONTAINS
INTEGER FUNCTION loc(str)
CHARACTER(len=*), INTENT(in) :: str
INTEGER :: i, ind
loc = 0
DO i=1,nc
ind = INDEX(which(i), str(1:lstr))
IF( ind .GT. 0 .AND. LEN_TRIM(which(i)) .EQ. lstr ) THEN
loc = i
EXIT
END IF
END DO
END FUNCTION loc
END SUBROUTINE timera
!================================================================================
SUBROUTINE readbdata
nlres = bdata%nlres
nlsave = bdata%nlsave
newres = bdata%newres
nlxg = bdata%nlxg
nlppform = bdata%nlppform
nlPhis = bdata%nlPhis
nlclassical = bdata%nlclassical
nplasma = bdata%nplasma
nz = bdata%nz
it0d = bdata%it0d
it2d = bdata%it2d
itparts = bdata%itparts
itgraph = bdata%itgraph
distribtype = bdata%distribtype
nblock = bdata%nblock
nrun = bdata%nrun
job_time = bdata%job_time
extra_time = bdata%extra_time
tmax = bdata%tmax
dt = bdata%dt
potinn = bdata%potinn
potout = bdata%potout
B0 = bdata%B0
n0 = bdata%n0
temp = bdata%temp
Rcurv = bdata%Rcurv
width = bdata%width
H0 = bdata%H0
P0 = bdata%P0
femorder = bdata%femorder
ngauss = bdata%ngauss
nnr = bdata%nnr
lz = bdata%lz
radii = bdata%radii
plasmadim = bdata%plasmadim
resfile = bdata%resfile
partperiodic = bdata%partperiodic
samplefactor = bdata%samplefactor
END SUBROUTINE readbdata
!================================================================================
END MODULE basic
diff --git a/src/beam_mod.f90 b/src/beam_mod.f90
index bae4781..d8a85c3 100644
--- a/src/beam_mod.f90
+++ b/src/beam_mod.f90
@@ -1,1620 +1,1477 @@
!------------------------------------------------------------------------------
! EPFL/Swiss Plasma Center
!------------------------------------------------------------------------------
!
! MODULE: beam
!
!> @author
!> Guillaume Le Bars EPFL/SPC
!> Patryk Kaminski EPFL/SPC
!> Trach Minh Tran EPFL/SPC
!
! DESCRIPTION:
!> Module responsible for loading, advancing and computing the necessary diagnostics for the simulated particles.
!------------------------------------------------------------------------------
MODULE beam
!
USE constants
USE mpi
USE mpihelper
USE basic, ONLY: mpirank, mpisize
+ USE distrib
IMPLICIT NONE
!> Stores the particles properties for the run.
TYPE particles
INTEGER :: Nptot !< Local number of simulated particles
INTEGER, DIMENSION(:), ALLOCATABLE :: Rindex !< Index in the electric potential grid for the R direction
INTEGER, DIMENSION(:), ALLOCATABLE :: Zindex !< Index in the electric potential grid for the Z direction
INTEGER, DIMENSION(:), ALLOCATABLE :: partindex !< Index of the particle to be able to follow it when it goes from one MPI host to the other
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: R !< radial coordinates of the particles
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: Z !< longitudinal coordinates of the particles
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: THET !< azimuthal coordinates of the particles
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WZ !< axial radial relative distances to the left grid line
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WR !< radial relative distances to the bottom grid line
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: pot !< Electric potential
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: Er !< Radial Electric field
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: Ez !< Axial electric field
DOUBLE PRECISION, DIMENSION(:),POINTER:: UR !< normalized radial velocity at the current time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: URold !< normalized radial velocity at the previous time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: UTHET !< normalized azimuthal velocity at the current time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: UTHETold !< normalized azimuthal velocity at the previous time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: UZ !< normalized axial velocity at the current time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: UZold !< normalized axial velocity at the previous time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: Gamma !< Lorentz factor at the current time step
DOUBLE PRECISION, DIMENSION(:),POINTER:: Gammaold !< Lorentz factor at the previous time step
END TYPE particles
!
TYPE(particles) :: parts !< Storage for all the particles
SAVE :: parts
TYPE(particle), DIMENSION(:), ALLOCATABLE:: rrecvpartbuff, lrecvpartbuff, rsendpartbuff, lsendpartbuff ! buffers to send and receive particle from left and right processes
! Diagnostics (scalars)
DOUBLE PRECISION :: ekin=0 !< Total kinetic energz (J)
DOUBLE PRECISION :: epot=0 !< Total potential energy (J)
DOUBLE PRECISION :: etot=0 !< Current total energy (J)
DOUBLE PRECISION :: etot0=0 !< Initial total energy (J)
DOUBLE PRECISION :: loc_etot0=0 !< theoretical local total energy (J)
INTEGER, DIMENSION(3), SAVE :: ireducerequest=MPI_REQUEST_NULL !< MPI requests used for the IREDUCE in the diagnostic routine
!
INTEGER, DIMENSION(:), ALLOCATABLE :: Nplocs_all !< Array containing the local numbers of particles in each MPI process
LOGICAL:: collected=.false. !< Stores if the particles data have been collected to MPI root process during this timestep
!
CONTAINS
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Allocate the memory for the particles variable storing the particles quantities.
!
!> @param[inout] p the particles variable needing to be allocated.
!> @param[in] nparts the maximum number of particles that will be stored in this variable
!---------------------------------------------------------------------------
SUBROUTINE creat_parts(p, nparts)
TYPE(particles) :: p
INTEGER, INTENT(in) :: nparts
IF (.NOT. ALLOCATED(p%Z) ) THEN
p%Nptot = nparts
ALLOCATE(p%Z(nparts))
ALLOCATE(p%R(nparts))
ALLOCATE(p%THET(nparts))
ALLOCATE(p%WZ(nparts))
ALLOCATE(p%WR(nparts))
ALLOCATE(p%UR(nparts))
ALLOCATE(p%UZ(nparts))
ALLOCATE(p%UTHET(nparts))
ALLOCATE(p%URold(nparts))
ALLOCATE(p%UZold(nparts))
ALLOCATE(p%UTHETold(nparts))
ALLOCATE(p%Gamma(nparts))
ALLOCATE(p%Rindex(nparts))
ALLOCATE(p%Zindex(nparts))
ALLOCATE(p%partindex(nparts))
ALLOCATE(p%pot(nparts))
ALLOCATE(p%Er(nparts))
ALLOCATE(p%Ez(nparts))
ALLOCATE(p%GAMMAold(nparts))
parts%partindex=-1
parts%URold=0
parts%UZold=0
parts%UTHETold=0
parts%rindex=0
parts%zindex=0
parts%WR=0
parts%WZ=0
parts%UR=0
parts%UZ=0
parts%UTHET=0
parts%Z=0
parts%R=0
parts%THET=0
parts%Gamma=1
parts%Er=0
parts%Ez=0
parts%pot=0
parts%gammaold=1
END IF
END SUBROUTINE creat_parts
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Loads the particles at the beginning of the simulation and create the parts variable if necessary
!---------------------------------------------------------------------------
SUBROUTINE load_parts
USE basic, ONLY: nplasma, mpirank, ierr, distribtype, mpisize, nlclassical
USE mpi
INTEGER:: i
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: VZ, VR, VTHET
ALLOCATE(VZ(nplasma), VR(nplasma), VTHET(nplasma))
! Select case to define the type of distribution
SELECT CASE(distribtype)
CASE(1) ! Gaussian distribution in V and uniform in R
CALL loaduniformRZ(VR, VZ, VTHET)
CASE(2) !Stable distribution from Davidson 4.95 p.119
CALL loadDavidson(VR, VZ, VTHET, lodunir)
CASE(3) !Stable distribution from Davidson 4.95 p.119 but with distribution in R as 1/R**2
CALL loadDavidson(VR, VZ, VTHET, lodinvr)
CASE(4) !Stable distribution from Davidson 4.95 p.119 but with gaussian distribution in R
CALL loadDavidson(VR, VZ, VTHET, lodgausr)
CASE(5) !Stable distribution from Davidson 4.95 p.119 with gaussian in V computed from v_th given by temp
CALL loadDavidson(VR, VZ, VTHET, lodunir)
CASE(6) ! Uniform distribution in R and Z and Gaussian distribution in V with Vz<V_perp to satisfy magnetic mirror trapping
CALL loaduniformRZ(VR, VZ, VTHET)
VZ = VZ/50
CASE DEFAULT
IF (mpirank .eq. 0) WRITE(*,*) "Unknown type of distribution:", distribtype
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END SELECT
Do i=1,nplasma
parts%partindex(i)=i
END DO
IF(nlclassical) THEN
parts%Gamma=1
ELSE
parts%Gamma=sqrt(1/(1-VR**2+VZ**2+VTHET**2))
END IF
! Normalization of the velocities
parts%UR=parts%Gamma*VR
parts%UZ=parts%Gamma*VZ
parts%UTHET=parts%Gamma*VTHET
DEALLOCATE(VZ, VR, VTHET)
CALL localisation
IF(mpisize .gt. 1) THEN
CALL distribpartsonprocs
END IF
END SUBROUTINE load_parts
!---------------------------------------------------------------------------
! DESCRIPTION:
!> @brief Checks for each particle if the z position is outside of the local/global simulation space.
!> Depending on the boundary conditions, the leaving particles are sent to the correct neighbouring MPI process
!> or deleted.
!
!> @author Guillaume Le Bars EPFL/SPC
!---------------------------------------------------------------------------
SUBROUTINE bound
USE basic, ONLY: zgrid, nz, Zbounds, cstep, mpirank, partperiodic, step, leftproc, rightproc
INTEGER :: i, rsendnbparts=0, lsendnbparts=0, nblostparts=0
INTEGER, DIMENSION(parts%Nptot) :: sendhole
INTEGER, DIMENSION(parts%Nptot) :: losthole
LOGICAL:: leftcomm, rightcomm
rsendnbparts=0
lsendnbparts=0
nblostparts=0
losthole=0
sendhole=0
! We communicate with the left processus
leftcomm = leftproc .ne. -1 .or. partperiodic
! We communicate with the right processus
rightcomm = rightproc .ne. -1 .or. partperiodic
IF (parts%Nptot .NE. 0) THEN
! Boundary condition at z direction
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
DO i=1,parts%Nptot
IF(step .ne. 0) THEN
! If the particle is to the right of the local simulation space, it is sent to the right MPI process
IF (parts%Z(i) .ge. zgrid(Zbounds(mpirank+1))) THEN
!$OMP CRITICAL (nbparts)
IF(rightcomm) THEN
rsendnbparts=rsendnbparts+1
sendhole(lsendnbparts+rsendnbparts)=i
ELSE
!WRITE(*,*) "Particle:",i , " of process:", mpirank, "is out of bound in z"
!WRITE(*,*) "!!!!!!!!!! Particle removed !!!!!!!!!!"
nblostparts=nblostparts+1
losthole(nblostparts)=i
END IF
!$OMP END CRITICAL (nbparts)
! If the particle is to the left of the local simulation space, it is sent to the left MPI process
ELSE IF (parts%Z(i) .lt. zgrid(Zbounds(mpirank))) THEN
!$OMP CRITICAL (nbparts)
IF(leftcomm) THEN
lsendnbparts=lsendnbparts+1
sendhole(lsendnbparts+rsendnbparts)=-i
ELSE
!WRITE(*,*) "Particle:",i , " of process:", mpirank, "is out of bound in z"
!WRITE(*,*) "!!!!!!!!!! Particle removed !!!!!!!!!!"
nblostparts=nblostparts+1
losthole(nblostparts)=i
END IF
!$OMP END CRITICAL (nbparts)
END IF
END IF
! The periodic boundary conditions in z are here applied
DO WHILE (parts%Z(i) .GT. zgrid(nz))
parts%Z(i) = parts%Z(i) - zgrid(nz) + zgrid(0)
END DO
DO WHILE (parts%Z(i) .LT. zgrid(0))
parts%Z(i) = parts%Z(i) + zgrid(nz) - zgrid(0)
END DO
END DO
!$OMP END PARALLEL DO
IF(mpisize .gt. 1 .and. step .ne. 0) THEN
! We send the particles leaving the local simulation space to the closest neighbour
CALL particlescommunication(lsendnbparts, rsendnbparts, sendhole)
END IF
! If the boundary conditions are not periodic, we delete the corresponding particles
IF(nblostparts .gt. 0) THEN
DO i=nblostparts,1,-1
CALL delete_part(losthole(i))
END DO
END IF
END IF
END subroutine bound
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Compute the grid cell indices for each particle as well as the distance weight Wr, Wz.
!---------------------------------------------------------------------------
SUBROUTINE localisation
USE basic, ONLY: zgrid, rgrid, dz, nr, nnr, dr, rnorm
INTEGER :: j,i, nblostparts=0
INTEGER, DIMENSION(parts%Nptot) :: losthole
i=1
losthole=0
IF (parts%Nptot .NE. 0) THEN
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
DO i=1,parts%Nptot
parts%zindex(i)=(parts%Z(i)-zgrid(0))/dz
IF (parts%R(i) .GT. rgrid(0) .AND. parts%R(i) .LT. rgrid(nnr(1))) THEN
parts%rindex(i)=(parts%R(i)-rgrid(0))/dr(1)
ELSE IF(parts%R(i) .GT. rgrid(nnr(1)) .AND. parts%R(i) .LT. rgrid(nnr(1)+nnr(2))) THEN
parts%rindex(i)=(parts%R(i)-rgrid(nnr(1)))/dr(2)+nnr(1)
ELSE IF(parts%R(i) .GT. rgrid(nnr(1)+nnr(2)) .AND. parts%R(i) .LT. rgrid(nr)) THEN
parts%rindex(i)=(parts%R(i)-rgrid(nnr(1)+nnr(2)))/dr(3)+nnr(1)+nnr(2)
ELSE
! If the particle is outside of the simulation space in the r direction, it is deleted.
WRITE(*,*) "Particle:",i , " of process:", mpirank, "is out of bound in r:", parts%R(i)*rnorm, rgrid(0)*rnorm, rgrid(nr)*rnorm
WRITE(*,*) "!!!!!!!!!! Particle removed !!!!!!!!!!"
!$OMP CRITICAL (lostparts)
nblostparts=nblostparts+1
losthole(nblostparts)=i
!$OMP END CRITICAL (lostparts)
END IF
END DO
!$OMP END PARALLEL DO
IF(nblostparts.gt.0) THEN
DO j=nblostparts,1,-1
CALL delete_part(losthole(j))
END DO
END IF
!$OMP PARALLEL DO SIMD DEFAULT(SHARED)
DO i=1,parts%Nptot
parts%WZ(i)=(parts%Z(i)-zgrid(parts%zindex(i)))/dz;
parts%WR(i)=(parts%R(i)-rgrid(parts%rindex(i)))/(rgrid(parts%rindex(i)+1)-rgrid(parts%rindex(i)));
END DO
!$OMP END PARALLEL DO SIMD
END IF
END SUBROUTINE localisation
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief General routine to compute the velocities at time t+1.
!> This routine allows to treat the classical and relativistic case efficiently from a numerical standpoint,
!> by using a pointer to the routine computing gamma. This avoid the nlclassical flag check on each particle.
!
!---------------------------------------------------------------------------
SUBROUTINE comp_velocity
!
! Computes the new velocity of the particles due to Lorentz force
!
USE basic, ONLY : nlclassical
! Store old Velocities
CALL swappointer(parts%UZold, parts%UZ)
CALL swappointer(parts%URold, parts%UR)
CALL swappointer(parts%UTHETold, parts%UTHET)
CALL swappointer(parts%Gammaold, parts%Gamma)
IF (nlclassical) THEN
CALL comp_velocity_fun(gamma_classical)
ELSE
CALL comp_velocity_fun(gamma_relativistic)
END IF
END SUBROUTINE comp_velocity
!---------------------------------------------------------------------------
!> @author
!> Patryk Kaminski EPFL/SPC
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Routine called by comp_velocity to compute the velocities at time t+1.
!> This routine allows to treat the classical and relativistic case efficiently from a numerical standpoint,
!> by using the routine computing gamma as an input. This avoid the nlclassical flag check on each particle.
!
!> @param[in] gamma the function used to compute the value of the lorentz factor \f$\gamma\f$
!---------------------------------------------------------------------------
SUBROUTINE comp_velocity_fun(gamma)
!
! Computes the new velocity of the particles due to Lorentz force
!
USE basic, ONLY : omegac, omegap, dt, tnorm, BZ, BR, nz
interface
subroutine gamma(gam, UZ, UR, UTHET)
DOUBLE PRECISION, INTENT(IN):: UR,UZ,UTHET
DOUBLE PRECISION, INTENT(OUT):: gam
end subroutine
end interface
DOUBLE PRECISION :: tau
DOUBLE PRECISION:: BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR, ZBZ2, ZBR2
INTEGER:: J1, J2, J3, J4
INTEGER:: i
! Normalized time increment
tau=omegac/2/omegap*dt/tnorm
IF (parts%Nptot .NE. 0) THEN
!$OMP PARALLEL DO SIMD DEFAULT(SHARED) PRIVATE(J1,J2,J3,J4,BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR, ZBZ2, ZBR2)
DO i=1,parts%Nptot
J1=(parts%rindex(i))*(nz+1)+parts%zindex(i)+1
J2=(parts%rindex(i))*(nz+1)+parts%zindex(i)+2
J3=(parts%rindex(i)+1)*(nz+1)+parts%zindex(i)+1
J4=(parts%rindex(i)+1)*(nz+1)+parts%zindex(i)+2
! Interpolation for magnetic field
BRZ=(1-parts%WZ(i))*(1-parts%WR(i))*Bz(J4) &
& +parts%WZ(i)*(1-parts%WR(i))*Bz(J3) &
& +(1-parts%WZ(i))*parts%WR(i)*Bz(J2) &
& +parts%WZ(i)*parts%WR(i)*Bz(J1)
BRR=(1-parts%WZ(i))*(1-parts%WR(i))*Br(J4) &
& +parts%WZ(i)*(1-parts%WR(i))*Br(J3) &
& +(1-parts%WZ(i))*parts%WR(i)*Br(J2) &
& +parts%WZ(i)*parts%WR(i)*Br(J1)
! First half of electric pulse
parts%UZ(i)=parts%UZold(i)+parts%Ez(i)*tau
parts%UR(i)=parts%URold(i)+parts%ER(i)*tau
CALL gamma(parts%Gamma(i), parts%UZ(i), parts%UR(i), parts%UTHETold(i))
! Rotation along magnetic field
ZBZ=tau*BRZ/parts%Gamma(i)
ZBR=tau*BRR/parts%Gamma(i)
ZPZ=parts%UZ(i)-ZBR*parts%UTHETold(i) !u'_{z}
ZPR=parts%UR(i)+ZBZ*parts%UTHETold(i) !u'_{r}
ZPTHET=parts%UTHETold(i)+(ZBR*parts%UZ(i)-ZBZ*parts%UR(i)) !u'_{theta}
SQR=1+ZBZ*ZBZ+ZBR*ZBR
ZBZ2=2*ZBZ/SQR
ZBR2=2*ZBR/SQR
parts%UZ(i)=parts%UZ(i)-ZBR2*ZPTHET !u+_{z}
parts%UR(i)=parts%UR(i)+ZBZ2*ZPTHET !u+_{r}
parts%UTHET(i)=parts%UTHETold(i)+(ZBR2*ZPZ-ZBZ2*ZPR) !u+_{theta}
! Second half of acceleration
parts%UZ(i)=parts%UZ(i)+parts%EZ(i)*tau
parts%UR(i)=parts%UR(i)+parts%ER(i)*tau
! Final computation of the Lorentz factor
CALL gamma(parts%Gamma(i), parts%UZ(i), parts%UR(i), parts%UTHETold(i))
END DO
!$OMP END PARALLEL DO SIMD
END IF
collected=.false.
END SUBROUTINE comp_velocity_fun
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Routine used to compute the lorentz factor \f$\gamma\f$ in the classical simulations.
!> This routine systematically returns 1.0 to treat the system according to classical dynamic.
!
!> @param[out] gamma the lorentz factor \f$\gamma\f$
!> @param[in] UZ \f$\gamma\beta_z=\gamma v_z/c\f$ the normalized particle longitudinal velocity
!> @param[in] UR \f$\gamma\beta_r=\gamma v_r/c\f$ the normalized particle radial velocity
!> @param[in] UTHET \f$\gamma\beta_\theta=\gamma v_\theta/c\f$ the normalized particle azimuthal velocity
!---------------------------------------------------------------------------
ELEMENTAL SUBROUTINE gamma_classical(gamma, UZ, UR, UTHET)
!$OMP declare simd(gamma_classical)
DOUBLE PRECISION, INTENT(IN):: UR,UZ,UTHET
DOUBLE PRECISION, INTENT(OUT):: gamma
gamma=1.0
END SUBROUTINE gamma_classical
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Routine used to compute the lorentz factor \f$\gamma\f$ in the relativistic simulations.
!> This routine computes the Lorentz factor \f$\gamma=\sqrt{1+\mathbf{\gamma\beta}^2}\f$
!
!> @param[out] gamma the lorentz factor \f$\gamma\f$
!> @param[in] UZ \f$\gamma\beta_z=\gamma v_z/c\f$ the normalized particle longitudinal velocity
!> @param[in] UR \f$\gamma\beta_r=\gamma v_r/c\f$ the normalized particle radial velocity
!> @param[in] UTHET \f$\gamma\beta_\theta=\gamma v_\theta/c\f$ the normalized particle azimuthal velocity
!---------------------------------------------------------------------------
ELEMENTAL SUBROUTINE gamma_relativistic(gamma, UZ, UR, UTHET)
!$OMP declare simd(gamma_relativistic)
DOUBLE PRECISION, INTENT(IN):: UR,UZ,UTHET
DOUBLE PRECISION, INTENT(OUT):: gamma
gamma=sqrt(1+UZ**2+UR**2+UTHET**2)
END SUBROUTINE
!---------------------------------------------------------------------------
!> @author
!> Patryk Kaminski EPFL/SPC
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Computes the particles position at time t+1
!> This routine computes the particles position at time t+1 according to the Bunemann algorithm.
!---------------------------------------------------------------------------
SUBROUTINE push
Use basic, ONLY: dt, tnorm
DOUBLE PRECISION:: XP, YP, COSA, SINA, U1, U2, ALPHA
INTEGER :: i
IF (parts%Nptot .NE. 0) THEN
!$OMP PARALLEL DO SIMD DEFAULT(SHARED) PRIVATE(XP, YP, COSA, SINA, U1, U2, ALPHA)
DO i=1,parts%Nptot
! Local Cartesian coordinates
XP=parts%R(i)+dt/tnorm*parts%UR(i)/parts%Gamma(i)
YP=dt/tnorm*parts%UTHET(i)/parts%Gamma(i)
! Conversion to cylindrical coordiantes
parts%Z(i)=parts%Z(i)+dt/tnorm*parts%UZ(i)/parts%Gamma(i)
parts%R(i)=sqrt(XP**2+YP**2)
! Computation of the rotation angle
IF (parts%R(i) .EQ. 0) THEN
COSA=1
SINA=0
ALPHA=0
ELSE
COSA=XP/parts%R(i)
SINA=YP/parts%R(i)
ALPHA=asin(SINA)
END IF
! New azimuthal position
parts%THET(i)=parts%THET(i)+ALPHA
! Velocity in rotated reference frame
U1=COSA*parts%UR(i)+SINA*parts%UTHET(i)
U2=-SINA*parts%UR(i)+COSA*parts%UTHET(i)
parts%UR(i)=U1
parts%UTHET(i)=U2
END DO
!$OMP END PARALLEL DO SIMD
END IF
collected=.false.
END SUBROUTINE push
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Computes several diagnostic quantities
!> This routine computes the total kinetic and electric potential energy. It also computes the first and second order
!> moments of the distribution function
!
!---------------------------------------------------------------------------
SUBROUTINE diagnostics
!
! Compute energies
!
USE constants, ONLY: vlight
USE basic, ONLY: qsim, phinorm, msim, cstep, nlclassical, nz, ierr, step, it0d, it2d, nlend, nr, itparts, nplasma, partperiodic, newres, Zbounds
INTEGER :: i, gridindex
INTEGER, DIMENSION(:) :: stat(3*MPI_STATUS_SIZE)
CALL MPI_WAITALL(3, ireducerequest, stat, ierr)
! Reset the quantities
ekin=0
epot=0
etot=0
! Computation of the kinetic and potential energy as well as fluid velocities and density
!$OMP PARALLEL DO SIMD REDUCTION(+:epot, ekin) DEFAULT(SHARED)
DO i=1,parts%Nptot
! Potential energy
epot=epot+0.5*qsim*parts%pot(i)*phinorm
! Kinetic energy
IF(.not. nlclassical) THEN
ekin=ekin+msim*vlight**2*(parts%Gamma(i)-1)
ELSE
ekin=ekin+0.5*msim*vlight**2*(abs(parts%URold(i)*parts%UR(i))+abs(parts%UZold(i)*parts%UZ(i))+abs(parts%UTHETold(i)*parts%UTHET(i)))
END IF
END DO
!$OMP END PARALLEL DO SIMD
! Shift to Etot at cstep=1 (not valable yet at cstep=0!)
IF(cstep.EQ.1 .or. (newres .AND. step .EQ. 1)) THEN
! Compute the local total energy
loc_etot0 = epot+ekin
END IF
etot=loc_etot0
! The computed energy is sent to the root process
IF(mpisize .gt.1) THEN
IF(mpirank .eq.0 ) THEN
CALL MPI_IREDUCE(MPI_IN_PLACE, epot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(1), ierr)
CALL MPI_IREDUCE(MPI_IN_PLACE, ekin, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(2), ierr)
CALL MPI_IREDUCE(etot, etot0, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(3), ierr)
ELSE
CALL MPI_IREDUCE(epot, epot, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(1), ierr)
CALL MPI_IREDUCE(ekin, ekin, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(2), ierr)
CALL MPI_IREDUCE(etot, etot0, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
& 0, MPI_COMM_WORLD, ireducerequest(3), ierr)
END IF
ELSE
etot0=loc_etot0
END IF
! Wait for the communication of the energy to be finished
CALL MPI_WAITALL(3, ireducerequest(1:3), stat(1:3*MPI_STATUS_SIZE), ierr)
!CALL MPI_WAIT(ireducerequest(2), stat(MPI_STATUS_SIZE+1:2*MPI_STATUS_SIZE), ierr)
! Compute the total energy
etot=epot+ekin
! Send the local number of particles on each node to the root process
IF(modulo(step,it0d).eq. 0 .and. mpisize .gt. 1) THEN
Nplocs_all(mpirank)=parts%Nptot
IF(mpirank .eq.0 ) THEN
CALL MPI_gather(MPI_IN_PLACE, 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,&
& 0, MPI_COMM_WORLD, ierr)
ELSE
CALL MPI_gather(Nplocs_all(mpirank), 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,&
& 0, MPI_COMM_WORLD, ierr)
END IF
IF(mpirank .eq. 0 .AND. partperiodic .and. INT(SUM(Nplocs_all)).ne. nplasma) THEN
!WRITE(*,*) "Error particle lost on some processus"
!CALL MPI_abort(MPI_COMM_WORLD,-1,ierr)
END IF
END IF
!Calls the communications to send the particles data to the root process for diagnostic file every itparts time steps
IF(mpisize .gt. 1 .and. (modulo(step,itparts) .eq. 0 .or. nlend)) THEN
CALL collectparts
END IF
end subroutine diagnostics
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Collect the particles positions and velocities on the root process.
!> If the collection has already been performed at this time step, the routine does nothing.
!
!---------------------------------------------------------------------------
SUBROUTINE collectparts
USE basic, ONLY: mpirank, mpisize, ierr
INTEGER, DIMENSION(:), ALLOCATABLE :: displs
INTEGER:: i
IF(collected) RETURN ! exit subroutine if particles have already been collected during this time step
IF(mpirank .ne. 0) THEN
ALLOCATE(displs(0:mpisize-1))
displs=0
! Send Particles informations to root process
CALL MPI_Gatherv(parts%Z, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%Z, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%R, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%R, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%THET, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%THET, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%UR, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UR, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%UZ, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UZ, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%UTHET, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UTHET, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%pot, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%pot, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%Rindex, Nplocs_all(mpirank), MPI_INTEGER, parts%Rindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%Zindex, Nplocs_all(mpirank), MPI_INTEGER, parts%Zindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(parts%partindex, Nplocs_all(mpirank), MPI_INTEGER, parts%partindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
ELSE
ALLOCATE(displs(0:mpisize-1))
displs(0)=0
Do i=1,mpisize-1
displs(i)=displs(i-1)+Nplocs_all(i-1)
END DO
! Receive particle information from all processes
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%Z, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%R, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%THET, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UR, Nplocs_all, displs,&
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UZ, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%UTHET, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_DOUBLE_PRECISION, parts%pot, Nplocs_all, displs, &
& MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_INTEGER, parts%Rindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_INTEGER, parts%Zindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nplocs_all(mpirank), MPI_INTEGER, parts%partindex, Nplocs_all, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
parts%partindex(sum(Nplocs_all)+1:)=-1
END IF
collected=.TRUE.
END SUBROUTINE collectparts
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Computes the velocities at time t-1/2 to keep the second order precision in time on the velocity.
!
!---------------------------------------------------------------------------
SUBROUTINE adapt_vinit
!! Computes the velocity at time -dt/2 from velocities computed at time 0
!
USE basic, ONLY : omegac, omegap, dt, tnorm, BZ, BR, nlclassical, phinorm, nz, distribtype, H0, vnorm
DOUBLE PRECISION :: tau, BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, &
& SQR, ZBZ2, ZBR2, Vperp, v2
INTEGER :: J1, J2, J3, J4, i
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: VZ, VR, VTHET
! In case Davidson distribution is used the longitudinal and radial velocities are adapted to take into account the
! electric potential.
IF(distribtype .EQ. 2 .OR. distribtype .EQ. 3 .OR. distribtype .EQ. 4) THEN
ALLOCATE(VR(parts%Nptot),VZ(parts%Nptot),VTHET(parts%Nptot))
CALL loduni(7,VZ)
VZ=VZ*2*pi
VTHET=parts%UTHET/parts%Gamma*vnorm
DO i=1,parts%Nptot
Vperp=sqrt(MAX(2*H0/me+2*elchar/me*parts%pot(i)*phinorm-VTHET(i)**2,0.0_db))
VR(i)=Vperp*sin(VZ(i))
VZ(i)=Vperp*cos(VZ(i))
IF(nlclassical) THEN
parts%Gamma(i)=1
ELSE
v2=VR(i)**2+VZ(i)**2+VTHET(i)**2
parts%Gamma(i)=sqrt(1/(1-v2/vnorm**2))
END IF
parts%UR(i)=parts%Gamma(i)*VR(i)/vnorm
parts%UZ(i)=parts%Gamma(i)*VZ(i)/vnorm
parts%UTHET(i)=parts%Gamma(i)*VTHET(i)/vnorm
END DO
DEALLOCATE(VR,VZ,VTHET)
END IF
! Normalised time increment
tau=-omegac/2/omegap*dt/tnorm
! Store old Velocities
CALL swappointer(parts%UZold, parts%UZ)
CALL swappointer(parts%URold, parts%UR)
CALL swappointer(parts%UTHETold, parts%UTHET)
CALL swappointer(parts%Gammaold, parts%Gamma)
IF (parts%Nptot .NE. 0) THEN
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,J1,J2,J3,J4,BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR, ZBZ2, ZBR2)
DO i=1,parts%Nptot
! Compute the particle linear indices for the magnetic field interpolation
J1=(parts%rindex(i))*(nz+1)+parts%zindex(i)+1
J2=J1+1
J3=(parts%rindex(i)+1)*(nz+1)+parts%zindex(i)+1
J4=J3+1
! Interpolation for magnetic field
BRZ=(1-parts%WZ(i))*(1-parts%WR(i))*Bz(J4) &
& +parts%WZ(i)*(1-parts%WR(i))*Bz(J3) &
& +(1-parts%WZ(i))*parts%WR(i)*Bz(J2) &
& +parts%WZ(i)*parts%WR(i)*Bz(J1)
BRR=(1-parts%WZ(i))*(1-parts%WR(i))*Br(J4) &
& +parts%WZ(i)*(1-parts%WR(i))*Br(J3) &
& +(1-parts%WZ(i))*parts%WR(i)*Br(J2) &
& +parts%WZ(i)*parts%WR(i)*Br(J1)
! Half inverse Rotation along magnetic field
ZBZ=tau*BRZ/parts%Gammaold(i)
ZBR=tau*BRR/parts%Gammaold(i)
SQR=1+ZBZ*ZBZ+ZBR*ZBR
ZPZ=(parts%UZold(i)-ZBR*parts%UTHETold(i))/SQR !u-_{z}
ZPR=(parts%URold(i)+ZBZ*parts%UTHETold(i))/SQR !u-_{r}
ZPTHET=parts%UTHETold(i)+(ZBR*parts%UZold(i)-ZBZ*parts%URold(i))/SQR !u-_{theta}
parts%UZ(i)=ZPZ
parts%UR(i)=ZPR
parts%UTHET(i)=ZPTHET
! half of decceleration
parts%UZ(i)=parts%UZ(i)+parts%Ez(i)*tau
parts%UR(i)=parts%UR(i)+parts%Er(i)*tau
IF(.not. nlclassical) THEN
parts%Gamma(i)=sqrt(1+parts%UZ(i)**2+parts%UR(i)**2+parts%UTHET(i)**2)
END IF
END DO
!$OMP END PARALLEL DO
END IF
END SUBROUTINE adapt_vinit
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief In the case of MPI parallelism, computes the indices of the particle assigned to the current process.
!---------------------------------------------------------------------------
SUBROUTINE distribpartsonprocs
! Computes the start and end indices for the Z boundaries on local processus
! Computes the particle indices from initial particle loading vector, that stay in current process
USE basic, ONLY: nz, ierr, Zbounds
INTEGER:: k
DOUBLE PRECISION:: idealnbpartsperproc
INTEGER:: totparts ! Total number of particle from zgrid(0) to zgrid(k)
INTEGER:: partindexstart ! Starting index of local particle in the parts variable used later to move the local particles at the begining of the vector
INTEGER:: partindexlast ! Ending index of local particle in the parts variable used later to move the local particles at the begining of the vector
INTEGER, DIMENSION(0:nz):: partspercol ! Vector containing the number of particles between zgrid(n) and zgrid(n+1)
INTEGER:: Zmin, Zmax ! Minimum and maximum indices of particles in Z direction
INTEGER:: Zperproc, zindex
partspercol=0
idealnbpartsperproc = FLOOR(REAL(parts%Nptot)/REAL(mpisize))
Zmin=MINVAL(parts%Zindex)
Zmax=MAXVAL(parts%Zindex)
Zperproc=(Zmax-Zmin)/mpisize
DO k=1,parts%Nptot
zindex=parts%Zindex(k)
partspercol(zindex)=partspercol(zindex)+1
END DO
DO k=1,mpisize-1
IF(k .lt. mpisize-1-MODULO(Zmax-Zmin,mpisize)) THEN
Zbounds(k)=Zmin+k*Zperproc-1
ELSE
Zbounds(k)=Zmin+k*Zperproc-1+k-mpisize+2+MODULO(Zmax-Zmin,mpisize)
END IF
END DO
partindexstart=1
totparts=0
partindexlast=parts%Nptot
!DO k=0,mpisize-2
! Nplocs_all(k)=idealnbpartsperproc
!END DO
! NPlocs_all(mpisize-1)=idealnbpartsperproc+MODULO(nplasma,mpisize)
!DO k=1, mpisize-1
! Zbounds(k)=parts%Z(INT(k*idealnbpartsperproc))
!END DO
DO k=0,mpisize-1
Nplocs_all(k)=SUM(partspercol(Zbounds(k):Zbounds(k+1)-1))
END DO
! Store local end of particle vector
partindexlast=SUM(Nplocs_all(0:mpirank))
! Store local start of particle vector
IF(mpirank .ne. 0) partindexstart=SUM(Nplocs_all(0:mpirank-1))+1
IF(mpirank .ne. 0) THEN
DO k= partindexstart, partindexlast
CALL move_part(k,k-partindexstart+1)
END DO
END IF
IF(INT(SUM(Nplocs_all)) .ne. parts%Nptot) THEN
WRITE(*,*) "Error in particle counting on proc:", mpirank, " local sum:", INT(SUM(Nplocs_all)), " Nptot:", parts%Nptot
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END IF
parts%Nptot=Nplocs_all(mpirank)
WRITE(*,*) mpirank, " Zbounds: ", Zbounds(mpirank), Zbounds(mpirank+1), " indices ", partindexstart, partindexlast, " nptot", parts%Nptot
END SUBROUTINE distribpartsonprocs
!_______________________________________________________________________________
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Manage the particle communication between neighbours.
!> This routine is responsible to receive the incoming particles from the MPI neighbours and to send its outgoing
!> particles to these neighbours
!
!> @param [in] lsendnbparts number of particles to send to the left neighbour (mpirank-1)
!> @param [in] rsendnbparts number of particles to send to the right neighbour (mpirank+1)
!> @param [in] sendholes array containing the indices of the particle leaving the local domain in ascending order. If the index is positive, the particle goes to the right neigbour, and to the left neighbour if the index is negative
!---------------------------------------------------------------------------
SUBROUTINE particlescommunication(lsendnbparts, rsendnbparts, sendholes)
USE mpihelper, ONLY: particle_type
USE basic, ONLY: rightproc, leftproc, ierr
INTEGER, INTENT(in) :: lsendnbparts, rsendnbparts
INTEGER, INTENT(in) :: sendholes(parts%Nptot)
INTEGER, ASYNCHRONOUS :: rrecvnbparts=0, lrecvnbparts=0
INTEGER, DIMENSION(2), ASYNCHRONOUS :: sendrequest, recvrequest
INTEGER, DIMENSION(2), ASYNCHRONOUS :: sendstatus(2*MPI_STATUS_SIZE), recvstatus(2*MPI_STATUS_SIZE)
INTEGER :: lsentnbparts, rsentnbparts
INTEGER :: lreceivednbparts, rreceivednbparts
lsentnbparts=lsendnbparts
rsentnbparts=rsendnbparts
sendrequest=MPI_REQUEST_NULL
recvrequest=MPI_REQUEST_NULL
! Send and receive the number of particles to exchange
CALL MPI_IRECV(lrecvnbparts, 1, MPI_INTEGER, leftproc, 0, MPI_COMM_WORLD, recvrequest(1), ierr)
CALL MPI_IRECV(rrecvnbparts, 1, MPI_INTEGER, rightproc, 0, MPI_COMM_WORLD, recvrequest(2), ierr)
CALL MPI_ISEND(lsentnbparts, 1, MPI_INTEGER, leftproc, 0, MPI_COMM_WORLD, sendrequest(1), ierr)
CALL MPI_ISEND(rsentnbparts, 1, MPI_INTEGER, rightproc, 0, MPI_COMM_WORLD, sendrequest(2), ierr)
CALL MPI_Wait(recvrequest(1), recvstatus(1), ierr)
CALL MPI_Wait(recvrequest(2), recvstatus(2), ierr)
recvrequest=MPI_REQUEST_NULL
lreceivednbparts=lrecvnbparts
rreceivednbparts=rrecvnbparts
! Re/allocate enough memory to store the incoming particles
IF( ALLOCATED(rrecvpartbuff) .AND. (size(rrecvpartbuff) .lt. rrecvnbparts) ) DEALLOCATE(rrecvpartbuff)
IF(.not. ALLOCATED(rrecvpartbuff) .and. rrecvnbparts .gt. 0) ALLOCATE(rrecvpartbuff(INT(rreceivednbparts*1.3)))
IF( ALLOCATED(lrecvpartbuff) .AND. (size(lrecvpartbuff) .lt. lrecvnbparts) ) DEALLOCATE(lrecvpartbuff)
IF((.not. ALLOCATED(lrecvpartbuff) ).and. lrecvnbparts .gt. 0) ALLOCATE(lrecvpartbuff(INT(lreceivednbparts*1.3)))
! Receive particles from left and right processes to the corresponding buffers
IF ( lrecvnbparts .gt. 0) THEN
CALL MPI_IRECV(lrecvpartbuff, lreceivednbparts, particle_type, leftproc, 1, MPI_COMM_WORLD, recvrequest(1), ierr)
END IF
IF( rrecvnbparts .gt. 0) THEN
CALL MPI_IRECV(rrecvpartbuff, rreceivednbparts, particle_type, rightproc, 1, MPI_COMM_WORLD, recvrequest(2), ierr)
END IF
! Copy the leaving particles to the corresponding send buffers
IF ( (lsendnbparts + rsendnbparts) .gt. 0) THEN
CALL AddPartSendBuffers(lsendnbparts, rsendnbparts, sendholes)
END IF
CALL MPI_Wait(sendrequest(1), sendstatus(1), ierr)
CALL MPI_Wait(sendrequest(2), sendstatus(MPI_STATUS_SIZE+1), ierr)
! Send the particles to the left and right neighbours
IF( lsendnbparts .gt. 0) THEN
CALL MPI_ISEND(lsendpartbuff, lsendnbparts, particle_type, leftproc, 1, MPI_COMM_WORLD, sendrequest(1), ierr)
END IF
IF( rsendnbparts .gt. 0) THEN
CALL MPI_ISEND(rsendpartbuff, rsendnbparts, particle_type, rightproc, 1, MPI_COMM_WORLD, sendrequest(2), ierr)
END IF
! Receive the incoming parts in the receive buffers
IF ( lreceivednbparts .gt. 0) THEN
CALL MPI_Wait(recvrequest(1), recvstatus(1), ierr)
IF(ierr .ne. MPI_SUCCESS) THEN
WRITE(*,*) "Error in particle reception on proc:", mpirank, " error code:", ierr, "status:", recvstatus(1)
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END IF
END IF
IF ( rreceivednbparts .gt. 0) THEN
CALL MPI_Wait(recvrequest(2), recvstatus(MPI_STATUS_SIZE+1), ierr)
IF(ierr .ne. MPI_SUCCESS) THEN
WRITE(*,*) "Error in particle reception on proc:", mpirank, " error code:", ierr, "status:", recvstatus(2)
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END IF
END IF
! Copy the incoming particles from the receive buffers to the simulation parts variable
CALL Addincomingparts(rreceivednbparts, lreceivednbparts, lsendnbparts+rsendnbparts, sendholes)
! Wait for the outgoing particles to be fully received by the neighbours
IF( lsendnbparts .gt. 0) THEN
CALL MPI_Wait(sendrequest(1), sendstatus(1), ierr)
END IF
IF( rsendnbparts .gt. 0) THEN
CALL MPI_Wait(sendrequest(2), sendstatus(2), ierr)
END IF
!
!
END SUBROUTINE particlescommunication
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Copy the particles from the receive buffers to the local simulation variable parts.
!> The incoming particles will first be stored in the holes left by the outgoing particles, then they
!> will be added at the end of the parts variable
!
!> @param [in] rrecvnbparts number of particles received from the right neighbour (mpirank+1)
!> @param [in] lrecvnbparts number of particles received from the left neighbour (mpirank-1)
!> @param [in] sendnbparts total number of particles having left the local domain
!> @param [in] sendholes array containing the indices of the particle having left the local domain in ascending order.
!---------------------------------------------------------------------------
SUBROUTINE Addincomingparts(rrecvnbparts, lrecvnbparts, sendnbparts, sendholes)
!
USE mpihelper
INTEGER, INTENT(in) :: rrecvnbparts, lrecvnbparts, sendnbparts
INTEGER, INTENT(in) :: sendholes(parts%Nptot)
INTEGER k,partpos, partdiff
! computes if we received less particles than we sent
partdiff=sendnbparts-rrecvnbparts-lrecvnbparts
! First import the particles coming from the right
IF(rrecvnbparts .gt. 0) THEN
Do k=1,rrecvnbparts
IF(k .le. sendnbparts) THEN
! Fill the holes
partpos=abs(sendholes(k))
ELSE
! Add at the end of parts
parts%Nptot=parts%Nptot+1
partpos=parts%Nptot
END IF
CALL Insertincomingpart(rrecvpartbuff, k, partpos)
END DO
END IF
! Then import the particles coming from the left
IF(lrecvnbparts .gt. 0) THEN
Do k=1,lrecvnbparts
IF(k+rrecvnbparts .le. sendnbparts) THEN
partpos=abs(sendholes(k+rrecvnbparts))
ELSE
parts%Nptot=parts%Nptot+1
partpos=parts%Nptot
END IF
CALL Insertincomingpart(lrecvpartbuff, k, partpos)
END DO
END IF
! If we received less particles than we sent, we fill the remaining holes with the particles from the end of the
! parts arrays
IF(partdiff .gt. 0) THEN
DO k=rrecvnbparts+lrecvnbparts+1, sendnbparts
CALL move_part(parts%Nptot,abs(sendholes(k)))
parts%Nptot = parts%Nptot-1
END DO
END IF
!
END SUBROUTINE Addincomingparts
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Copy one particle from the receive buffers to the local simulation variable parts.
!
!> @param [in] buffer receive buffer containing the particles parameters to copy from
!> @param [in] bufferindex particle index in the receive buffer
!> @param [in] partsindex destination particle index in the local parts variable
!---------------------------------------------------------------------------
SUBROUTINE Insertincomingpart(buffer, bufferindex, partsindex)
USE mpihelper
INTEGER, INTENT(in) :: bufferindex, partsindex
TYPE(particle), DIMENSION(:), ALLOCATABLE, INTENT(in) :: buffer
parts%partindex(partsindex) = buffer(bufferindex)%partindex
parts%Rindex(partsindex) = buffer(bufferindex)%Rindex
parts%Zindex(partsindex) = buffer(bufferindex)%Zindex
parts%R(partsindex) = buffer(bufferindex)%R
parts%Z(partsindex) = buffer(bufferindex)%Z
parts%THET(partsindex) = buffer(bufferindex)%THET
parts%UZ(partsindex) = buffer(bufferindex)%UZ
parts%UR(partsindex) = buffer(bufferindex)%UR
parts%UTHET(partsindex) = buffer(bufferindex)%UTHET
parts%Gamma(partsindex) = buffer(bufferindex)%Gamma
!
!
END SUBROUTINE Insertincomingpart
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Copy one particle from the local parts variable to the send buffer.
!
!> @param [in] buffer send buffer to copy to
!> @param [in] bufferindex particle index in the send buffer
!> @param [in] partsindex origin particle index in the local parts variable
!---------------------------------------------------------------------------
SUBROUTINE Insertsentpart(buffer, bufferindex, partsindex)
USE mpihelper
INTEGER, INTENT(in) :: bufferindex, partsindex
TYPE(particle), DIMENSION(:), ALLOCATABLE, INTENT(inout) :: buffer
buffer(bufferindex)%partindex = parts%partindex(partsindex)
buffer(bufferindex)%Rindex = parts%Rindex(partsindex)
buffer(bufferindex)%Zindex = parts%Zindex(partsindex)
buffer(bufferindex)%R = parts%R(partsindex)
buffer(bufferindex)%Z = parts%Z(partsindex)
buffer(bufferindex)%THET = parts%THET(partsindex)
buffer(bufferindex)%UZ = parts%UZ(partsindex)
buffer(bufferindex)%UR = parts%UR(partsindex)
buffer(bufferindex)%UTHET = parts%UTHET(partsindex)
buffer(bufferindex)%Gamma = parts%Gamma(partsindex)
!
END SUBROUTINE Insertsentpart
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Copy the particles from the local parts variable to the left and right send buffers.
!
!> @param [in] lsendnbparts number of particles to send to the left neighbour (mpirank-1)
!> @param [in] rsendnbparts number of particles to send to the right neighbour (mpirank+1)
!> @param [in] sendholes array containing the indices of the particle leaving the local domain in ascending order. If the index is positive, the particle goes to the right neigbour, and to the left neighbour if the index is negative
!---------------------------------------------------------------------------
SUBROUTINE AddPartSendBuffers(lsendnbparts, rsendnbparts, sendholes)
!
USE mpihelper
INTEGER, INTENT(in) :: lsendnbparts, rsendnbparts
INTEGER, INTENT(in) :: sendholes(parts%Nptot)
INTEGER:: partpos, k
INTEGER:: lsendpos, rsendpos
lsendpos=0
rsendpos=0
! Verify if the buffers are big enough to store the outgoing particles
IF( ALLOCATED(rsendpartbuff) .AND. size(rsendpartbuff) .lt. rsendnbparts ) DEALLOCATE(rsendpartbuff)
IF( ALLOCATED(lsendpartbuff) .AND. size(lsendpartbuff) .lt. lsendnbparts ) DEALLOCATE(lsendpartbuff)
! Allocate the buffers if needed
IF(.not. ALLOCATED(rsendpartbuff) .and. rsendnbparts .gt. 0) ALLOCATE(rsendpartbuff(INT(rsendnbparts*1.3)))
IF(.not. ALLOCATED(lsendpartbuff) .and. lsendnbparts .gt. 0) ALLOCATE(lsendpartbuff(INT(lsendnbparts*1.3)))
! Loop over the outgoing particles and fill the correct send buffer
Do k=lsendnbparts+rsendnbparts,1,-1
partpos=abs(sendholes(k))
IF(sendholes(k) .GT. 0) THEN
rsendpos=rsendpos+1
CALL Insertsentpart(rsendpartbuff, rsendpos, partpos)
ELSE IF(sendholes(k) .LT. 0) THEN
lsendpos=lsendpos+1
CALL Insertsentpart(lsendpartbuff, lsendpos, partpos)
END IF
END DO
!
!
END SUBROUTINE AddPartSendBuffers
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!> @brief Exchange two particles in the parts variable.
!
!> @param [in] index1 index in parts of the first particle to exchange.
!> @param [in] index2 index in parts of the second particle to exchange.
!---------------------------------------------------------------------------
SUBROUTINE exchange_parts(index1, index2)
INTEGER, INTENT(IN) :: index1, index2
DOUBLE PRECISION:: R, Z, THET, UR, UZ, UTHET, Gamma
INTEGER :: Rindex, Zindex, partindex
!! Exchange particle at index1 with particle at index2
! Store part at index1 in temporary value
partindex= parts%partindex(index1)
Gamma = parts%Gamma(index1)
R = parts%R(index1)
Z = parts%Z(index1)
THET = parts%THET(index1)
UR = parts%UR(index1)
UTHET = parts%UTHET(index1)
UZ = parts%UZ(index1)
Rindex = parts%Rindex(index1)
Zindex = parts%Zindex(index1)
! Move part at index2 in part at index 1
parts%partindex(index1)= parts%partindex(index2)
parts%Gamma(index1) = parts%Gamma(index2)
parts%R(index1) = parts%R(index2)
parts%Z(index1) = parts%Z(index2)
parts%THET(index1) = parts%THET(index2)
parts%UR(index1) = parts%UR(index2)
parts%UTHET(index1) = parts%UTHET(index2)
parts%UZ(index1) = parts%UZ(index2)
parts%Rindex(index1) = parts%Rindex(index2)
parts%Zindex(index1) = parts%Zindex(index2)
! Move temporary values from part(index1) to part(index2)
parts%partindex(index2)= partindex
parts%Gamma(index2) = Gamma
parts%R(index2) = R
parts%Z(index2) = Z
parts%THET(index2) = THET
parts%UR(index2) = UR
parts%UTHET(index2) = UTHET
parts%UZ(index2) = UZ
parts%Rindex(index2) = Rindex
parts%Zindex(index2) = Zindex
END SUBROUTINE exchange_parts
+
+ SUBROUTINE add_created_part(buffer)
+ IMPLICIT NONE
+ TYPE(particle), DIMENSION(:), INTENT(in) :: buffer
+ INTEGER::i, nptotinit
+ nptotinit=parts%Nptot+1
+ DO i=1,size(buffer,1)
+ ! if there is still space in the parts simulation buffer, copy the particle
+ IF(parts%Nptot .eq. size(parts%Z,1)) THEN
+ WRITE(*,*) "Particle buffer full: impossible to create part with maxwellian source"
+ RETURN
+ END IF
+ parts%Nptot=parts%Nptot+1
+ CALL Insertincomingpart(buffer,i,parts%Nptot)
+ END DO
+
+ ! Compute the energy added by these new particles for energy conservation diagnostic
+ IF(nptotinit .le. parts%Nptot) THEN
+ CALL getgrad(splrz, parts%Z(nptotinit:parts%Nptot), parts%R(nptotinit:parts%Nptot), &
+ & parts%pot(nptotinit:parts%Nptot), parts%EZ(nptotinit:parts%Nptot), parts%ER(nptotinit:parts%Nptot))
+ parts%EZ(nptotinit:parts%Nptot)=-parts%Ez(nptotinit:parts%Nptot)
+ parts%ER(nptotinit:parts%Nptot)=-parts%ER(nptotinit:parts%Nptot)
+
+ loc_etot0=loc_etot0+qsim*sum(parts%pot(nptotinit:parts%Nptot))*phinorm
+ IF(.not. nlclassical) THEN
+ loc_etot0=loc_etot0+sum(msim*vlight**2*(parts%Gamma(nptotinit:parts%Nptot)-1))
+ ELSE
+ loc_etot0=loc_etot0+0.5*msim*vlight**2*sum(parts%UR(nptotinit:parts%Nptot)**2 &
+ & +parts%UZ(nptotinit:parts%Nptot)**2 &
+ & +parts%UTHET(nptotinit:parts%Nptot)**2)
+ END IF
+ END IF
+ END SUBROUTINE
+
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Delete particle at given index removing its energy from the system
!
!> @param [in] index index of particle to be deleted
!---------------------------------------------------------------------------
SUBROUTINE delete_part(index)
!! This will destroy particle at index
USE constants, ONLY: vlight
USE basic, ONLY: qsim, phinorm, msim, nlclassical
INTEGER, INTENT(IN) :: index
IF(index .le. parts%Nptot) THEN
loc_etot0=loc_etot0-qsim*parts%pot(index)*phinorm
IF(.not. nlclassical) THEN
loc_etot0=loc_etot0-msim*vlight**2*(parts%Gamma(index)-1)
ELSE
loc_etot0=loc_etot0-0.5*msim*vlight**2*(abs(parts%URold(index)*parts%UR(index))+abs(parts%UZold(index)*parts%UZ(index))+abs(parts%UTHETold(index)*parts%UTHET(index)))
END IF
! We fill the gap
CALL move_part(parts%Nptot, index)
parts%partindex(parts%Nptot)=-1
! Reduce the total number of simulated parts
parts%Nptot=parts%Nptot-1
END IF
END SUBROUTINE delete_part
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Move particle with index sourceindex to particle with index destindex.
!> !WARNING! This will destroy particle at destindex.
!
!> @param [in] sourceindex index in parts of the particle to move.
!> @param [in] destindex index in parts of the moved particle destination.
!---------------------------------------------------------------------------
SUBROUTINE move_part(sourceindex, destindex)
!! This will destroy particle at destindex
INTEGER, INTENT(IN) :: destindex, sourceindex
! Move part at sourceindex in part at destindex
parts%partindex(destindex)= parts%partindex(sourceindex)
parts%Gamma(destindex) = parts%Gamma(sourceindex)
parts%R(destindex) = parts%R(sourceindex)
parts%Z(destindex) = parts%Z(sourceindex)
parts%THET(destindex) = parts%THET(sourceindex)
parts%UR(destindex) = parts%UR(sourceindex)
parts%UTHET(destindex) = parts%UTHET(sourceindex)
parts%UZ(destindex) = parts%UZ(sourceindex)
parts%Rindex(destindex) = parts%Rindex(sourceindex)
parts%Zindex(destindex) = parts%Zindex(sourceindex)
END SUBROUTINE move_part
-
-!---------------------------------------------------------------------------
-!> @author
-!> Trach Minh Tran EPFL/SPC
-!
-! DESCRIPTION:
-!>
-!> @brief Load a uniform distribution using the Hammersley's sequence (0<=y<=1).
-!> (nbase = 0 => Random sampling)
-!
-!> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
-!> @param [out] y array containing the random variables.
-!---------------------------------------------------------------------------
- SUBROUTINE loduni(nbase, y)
-!
-! Load a uniform distribution using the Hammersley's sequence.
-! (nbase = 0 => Random sampling)
-!
- INTEGER, INTENT(in) :: nbase
- DOUBLE PRECISION, INTENT(inout) :: y(:)
- INTEGER :: n, i
-!
- n = SIZE(y)
-!
- SELECT CASE (nbase)
- CASE(0)
- CALL RANDOM_NUMBER(y)
- CASE(1)
- DO i=1,n
- y(i) = (i-0.5_db)/n
- END DO
- CASE(2:)
- DO i=1,n
- y(i) = rev(nbase,i)
- END DO
- CASE default
- WRITE(*,'(a,i5)') 'Invalid value of NBASE =', nbase
- END SELECT
-!
- END SUBROUTINE loduni
-
-!---------------------------------------------------------------------------
-!> @author
-!> Trach Minh Tran EPFL/SPC
-!
-! DESCRIPTION:
-!>
-!> @brief Load a gaussian distribution using a uniform distribution according to the Hammersley's sequence.
-!> (nbase = 0 => Random sampling)
-!
-!> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
-!> @param [out] y array containing the random variables.
-!---------------------------------------------------------------------------
- SUBROUTINE lodgaus(nbase, y)
-!
-! Sample y from the Gauss distributrion
-!
- DOUBLE PRECISION, INTENT(inout) :: y(:)
- INTEGER, INTENT(in) :: nbase
-!
- INTEGER :: n, i, iflag
- DOUBLE PRECISION :: r(SIZE(y))
- DOUBLE PRECISION :: t
-!
- DOUBLE PRECISION :: c0, c1, c2
- DOUBLE PRECISION :: d1, d2, d3
- DATA c0, c1, c2/2.515517_db, 0.802853_db, 0.010328_db/
- DATA d1, d2, d3/1.432788_db, 0.189269_db, 0.001308_db/
-!
- n = SIZE(y)
- CALL loduni(nbase, r)
- r = 1.0E-5 + 0.99998*r
-!
- DO i=1,n
- iflag = 1
- IF (r(i) .GT. 0.5) THEN
- r(i) = 1.0 - r(i)
- iflag = -1
- END IF
- t = SQRT(LOG(1.0/(r(i)*r(i))))
- y(i) = t - (c0+c1*t+c2*t**2) / (1.0+d1*t+d2*t**2+d3*t**3)
- y(i) = y(i) * iflag
- END DO
- y = y - SUM(y)/REAL(n)
- END SUBROUTINE lodgaus
- !________________________________________________________________________________
- SUBROUTINE lodinvr(nbase, y, ra, rb)
- !
- ! Sample y from the distribution f=1/(r)H(r-ra)H(rb-r) for where H is the heavyside function
- !
- DOUBLE PRECISION, INTENT(out) :: y(:)
- INTEGER, INTENT(in) :: nbase
- DOUBLE PRECISION, INTENT(in) :: rb, ra
- !
- DOUBLE PRECISION :: r(SIZE(y))
- !
- CALL loduni(nbase, r)
- r=r*log(rb/ra)
- y=ra*exp(r)
- END SUBROUTINE lodinvr
- !________________________________________________________________________________
- SUBROUTINE lodlinr(nbase, y, ra, rb)
- DOUBLE PRECISION, INTENT(out) :: y(:)
- INTEGER, INTENT(in) :: nbase
- DOUBLE PRECISION, INTENT(in) :: rb, ra
- !
- DOUBLE PRECISION :: r(SIZE(y))
- !
- CALL loduni(nbase, r)
- y=ra+sqrt(r)*(rb-ra)
- END SUBROUTINE lodlinr
- !________________________________________________________________________________
- SUBROUTINE lodunir(nbase, y, ra, rb)
- DOUBLE PRECISION, INTENT(out) :: y(:)
- INTEGER, INTENT(in) :: nbase
- DOUBLE PRECISION, INTENT(in) :: rb, ra
- !
- DOUBLE PRECISION :: r(SIZE(y))
- !
- CALL loduni(nbase, r)
- y=ra+(rb-ra)*r
- END SUBROUTINE lodunir
- !________________________________________________________________________________
- SUBROUTINE lodgausr(nbase, y, ra, rb)
- DOUBLE PRECISION, INTENT(out) :: y(:)
- INTEGER, INTENT(in) :: nbase
- DOUBLE PRECISION, INTENT(in) :: rb, ra
- !
- DOUBLE PRECISION :: r(SIZE(y))
- !
- CALL lodgaus(nbase, r)
- y=0.5*(rb+ra)+ 0.1*(rb-ra)*r
- END SUBROUTINE lodgausr
-!________________________________________________________________________________
- DOUBLE PRECISION FUNCTION rev(nbase,i)
-!
-! Return an element of the Hammersley's sequence
-!
- INTEGER, INTENT(IN) :: nbase ! Base of the Hammersley's sequence (IN)
- INTEGER, INTENT(IN) :: i ! Index of the sequence (IN)
-!
-! Local vars
- INTEGER :: j1, j2
- DOUBLE PRECISION :: xs, xsi
-!-----------------------------------------------------------------------
- xs = 0.0
- xsi = 1.0
- j2 = i
- DO
- xsi = xsi/nbase
- j1 = j2/nbase
- xs = xs + (j2-nbase*j1)*xsi
- j2 = j1
- IF( j2.LE.0 ) EXIT
- END DO
- rev = xs
- END FUNCTION rev
-!________________________________________________________________________________
- !Modified Bessel functions of the first kind of the first order
- FUNCTION bessi1(x)
- DOUBLE PRECISION :: bessi1,x
- DOUBLE PRECISION :: ax
- DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
- SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
- DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
- DATA q1,q2,q3,q4,q5,q6,q7,q8,q9 /0.39894228d0, -0.3988024d-1, -0.362018d-2, 0.163801d-2,-0.1031555d-1, &
- & 0.2282967d-1, -0.2895312d-1, 0.1787654d-1,-0.420059d-2/
- if (abs(x).lt.3.75) then
- y=(x/3.75)**2
- bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
- else
- ax=abs(x)
- y=3.75/ax
- bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
- if(x.lt.0.)bessi1=-bessi1
- endif
- return
- END FUNCTION bessi1
!________________________________________________________________________________
SUBROUTINE destroy_parts(p)
TYPE(particles) :: p
p%nptot=0
IF(ALLOCATED(p%Z)) DEALLOCATE(p%Z)
IF(ALLOCATED(p%R)) DEALLOCATE(p%R)
IF(ALLOCATED(p%THET)) DEALLOCATE(p%THET)
IF(ALLOCATED(p%WZ)) DEALLOCATE(p%WZ)
IF(ALLOCATED(p%WR)) DEALLOCATE(p%WR)
IF(ASSOCIATED(p%UR)) DEALLOCATE(p%UR)
IF(Associated(p%URold)) DEALLOCATE(p%URold)
IF(Associated(p%UZ)) DEALLOCATE(p%UZ)
IF(Associated(p%UZold)) DEALLOCATE(p%UZold)
IF(Associated(p%UTHET)) DEALLOCATE(p%UTHET)
IF(Associated(p%UTHETold)) DEALLOCATE(p%UTHETold)
IF(Associated(p%Gamma)) DEALLOCATE(p%Gamma)
IF(Associated(p%Gammaold)) DEALLOCATE(p%Gammaold)
IF(ALLOCATED(p%Rindex)) DEALLOCATE(p%Rindex)
IF(ALLOCATED(p%Zindex)) DEALLOCATE(p%Zindex)
IF(ALLOCATED(p%partindex)) DEALLOCATE(p%partindex)
END SUBROUTINE
!________________________________________________________________________________
SUBROUTINE clean_beam
!
CALL destroy_parts(parts)
!
END SUBROUTINE clean_beam
!________________________________________________________________________________
SUBROUTINE swappointer( pointer1, pointer2)
DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(inout):: pointer1, pointer2
DOUBLE PRECISION, DIMENSION(:), POINTER:: temppointer
temppointer=>pointer1
pointer1=>pointer2
pointer2=>temppointer
END SUBROUTINE swappointer
!_______________________________________________________________________________
SUBROUTINE loaduniformRZ(VR,VZ,VTHET)
USE basic, ONLY: plasmadim, rnorm, temp, vnorm
USE constants, ONLY: me, kb, elchar
DOUBLE PRECISION, INTENT(inout) ::VZ(:), VR(:), VTHET(:)
DOUBLE PRECISION:: vth
! Initial distribution in z with normalisation
CALL loduni(1,parts%Z(:))
parts%Z(:)=(plasmadim(1)+(plasmadim(2)-plasmadim(1))*parts%Z(:))/rnorm
! Initial distribution in r with normalisation
CALL loduni(2,parts%R(:))
parts%R=(plasmadim(3)+parts%R(:)*(plasmadim(4)-plasmadim(3)))/rnorm
! Initial velocities distribution
vth=sqrt(3*kb*temp/me)/vnorm !thermal velocity
CALL lodgaus(3,VZ)
CALL lodgaus(5,VR)
CALL lodgaus(7,VTHET)
VZ=VZ*vth
VR=VR*vth
VTHET=VTHET*vth
END SUBROUTINE loaduniformRZ
!_______________________________________________________________________________
SUBROUTINE loadDavidson(VR,VZ,VTHET,lodr)
USE constants, ONLY: me, kb, elchar
USE basic, ONLY: nplasma, rnorm, plasmadim, distribtype, H0, P0, Rcurv, B0, width, qsim, msim, vnorm, &
& omegac, zgrid, nz, rnorm, V, n0, nblock, temp
interface
subroutine lodr(nbase,y,ra,rb)
DOUBLE PRECISION, INTENT(out) :: y(:)
INTEGER, INTENT(in) :: nbase
DOUBLE PRECISION, INTENT(in) :: rb, ra
end subroutine
end interface
DOUBLE PRECISION, INTENT(INOUT)::VZ(:), VR(:), VTHET(:)
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE::ra, rb
DOUBLE PRECISION :: r0, athetpos, deltar2, rg, zg, halfLz, Mirrorratio, Le, Pcomp, Acomp, gamma, VOL, vth
INTEGER :: i, j, n, blockstart, blockend, addedpart, remainparts
INTEGER, DIMENSION(:), ALLOCATABLE :: blocksize
Allocate(ra(nblock),rb(nblock))
!r0=(plasmadim(4)+plasmadim(3))/2
r0=sqrt(4*H0/(me*omegac**2))
halfLz=(zgrid(nz)+zgrid(0))/2
MirrorRatio=(Rcurv-1)/(Rcurv+1)
DO n=1,nblock
! Compute limits in radius and load radii for each part
Le=(plasmadim(2)-plasmadim(1))/nblock*(n-0.5)-halfLz*rnorm+plasmadim(1)
deltar2=1-MirrorRatio*cos(2*pi*Le/width)
rb(n)=r0/deltar2*sqrt(1-P0*abs(omegac)/2/H0*deltar2+sqrt(1-P0*abs(omegac)/H0*deltar2))
ra(n)=r0/deltar2*sqrt(1-P0*abs(omegac)/2/H0*deltar2-sqrt(1-P0*abs(omegac)/H0*deltar2))
END DO
VOL=SUM(2*pi*ra*(rb-ra)*(plasmadim(2)-plasmadim(1))/nblock)
qsim=VOL*n0*elchar/nplasma
msim=abs(qsim)/elchar*me
V=VOL/rnorm**3
!H0=me*omegac**2*r0**2*0.5
gamma=1/sqrt(1-omegac**2*r0**2/vlight**2)
!P0=H0/omegac
blockstart=1
blockend=0
ALLOCATE(blocksize(nblock))
DO n=1,nblock
blocksize(n)=nplasma/VOL*2*pi*ra(n)*(rb(n)-ra(n))*(plasmadim(2)-plasmadim(1))/nblock
END DO
remainparts=parts%Nptot-SUM(blocksize)
addedpart=1
n=nblock/2
j=1
DO WHILE(remainparts .GT. 0)
blocksize(n)=blocksize(n)+addedpart
remainparts=remainparts-addedpart
n=n+j
j=-1*(j+SIGN(1,j))
END DO
DO n=1,nblock
blockstart=blockend+1
blockend=MIN(blockstart+blocksize(n)-1,parts%Nptot)
! Initial distribution in z with normalisation between magnetic mirrors
CALL loduni(1,parts%Z(blockstart:blockend))
parts%Z(blockstart:blockend)=(plasmadim(2)-plasmadim(1))/rnorm/nblock*((n-1)+parts%Z(blockstart:blockend))+plasmadim(1)/rnorm
CALL lodr(2,parts%R(blockstart:blockend),ra(n), rb(n))
parts%R(blockstart:blockend)=parts%R(blockstart:blockend)/rnorm
END DO
IF(distribtype .eq. 5) THEN
! Initial velocities distribution
vth=sqrt(3*kb*temp/me)/vnorm !thermal velocity
CALL lodgaus(3,VZ)
CALL lodgaus(5,VR)
CALL lodgaus(7,VTHET)
VZ=VZ*vth/4
VR=VR*8*vth
VTHET=VTHET*8*vth
ELSE
! Load velocities theta velocity
! Loading of r and z velocity is done in adapt_vinit to have
! access to parts%pot
DO i=1,parts%Nptot
! Interpolation for Magnetic potential
rg=parts%R(i)*rnorm
zg=(parts%Z(i)-halfLz)*rnorm
Athetpos=0.5*B0*(rg - width/pi*MirrorRatio*bessi1(2*pi*rg/width)*COS(2*pi*zg/width))
Pcomp=P0/rg/me
Acomp=-SIGN(elchar/me*Athetpos,qsim)
VTHET(i)=SIGN(MIN(abs(Pcomp+Acomp),sqrt(2*H0/me)),Pcomp+Acomp)
!VTHET(i)=Pcomp+Acomp
END DO
VTHET=VTHET/vnorm
VZ=0._db
VR=0._db
END IF
END SUBROUTINE loadDavidson
!===============================================================================
SUBROUTINE Temp_rescale
USE basic, ONLY: temprescale, nlclassical, nz
! INTEGER:: i, gridindex
! DOUBLE PRECISION :: vr, vz, vthet
! DO i=1,parts%Nptot
! gridindex=parts%zindex(i)+1+parts%rindex(i)*nz
! vr=parts%UR(i)/parts%Gamma(i)-fluidur(gridindex)
! vz=parts%UZ(i)/parts%Gamma(i)-fluiduz(gridindex)
! vthet=parts%UTHET(i)/parts%Gamma(i)-fluiduthet(gridindex)
! parts%UR(i)=vr*temprescale+fluidur(gridindex)
! parts%UTHET(i)=vthet*temprescale+fluiduthet(gridindex)
! parts%UZ(i)=vz*temprescale+fluiduz(gridindex)
! IF(nlclassical) THEN
! parts%Gamma(i)=1.0
! ELSE
! parts%Gamma(i)=1/sqrt(1-(parts%UR(i)**2+parts%UTHET(i)**2+parts%UZ(i)**2))
! END IF
! parts%UR(i)=parts%UR(i)*parts%Gamma(i)
! parts%UTHET(i)=parts%UTHET(i)*parts%Gamma(i)
! parts%UZ(i)=parts%UZ(i)*parts%Gamma(i)
! END DO
END SUBROUTINE Temp_rescale
SUBROUTINE upsample(samplefactor)
USE basic, ONLY : nplasma, qsim, msim, dt, dr, dz
INTEGER, INTENT(IN) ::samplefactor
INTEGER:: i, j, currentindex
DOUBLE PRECISION, DIMENSION(parts%Nptot) :: spreaddir ! random direction for the spread of each initial macro particle
DOUBLE PRECISION :: dir ! Direction in which the particle is moved
DOUBLE PRECISION :: dl ! Particle displacement used for
! Load and scale the direction angle for spreading the new particles
CALL loduni(2, spreaddir)
spreaddir=spreaddir*2*pi/samplefactor
dl=min(dz,minval(dr))/100
DO i=1,parts%Nptot
DO j=1,samplefactor-1
currentindex=parts%Nptot+(i-1)*(samplefactor-1)+j
CALL move_part(i,currentindex)
parts%partindex(currentindex)=currentindex
dir = spreaddir(i)+2*pi*j/samplefactor
parts%R(currentindex)=parts%R(currentindex) + dl*cos(dir)
parts%Z(currentindex)=parts%Z(currentindex) + dl*sin(dir)
END DO
parts%partindex(i)=i
parts%R(i)=parts%R(i) + dl*cos(spreaddir(i))
parts%Z(i)=parts%Z(i) + dl*sin(spreaddir(i))
END DO
nplasma=nplasma*samplefactor
qsim=qsim/samplefactor
msim=msim/samplefactor
parts%Nptot=parts%Nptot*samplefactor
END SUBROUTINE upsample
END MODULE beam
diff --git a/src/distrib_mod.f90 b/src/distrib_mod.f90
new file mode 100644
index 0000000..f5aae59
--- /dev/null
+++ b/src/distrib_mod.f90
@@ -0,0 +1,266 @@
+!------------------------------------------------------------------------------
+! EPFL/Swiss Plasma Center
+!------------------------------------------------------------------------------
+!
+! MODULE: distrib
+!
+!> @author
+!> Guillaume Le Bars EPFL/SPC
+!> Trach Minh Tran EPFL/SPC
+!
+! DESCRIPTION:
+!> Contains the routines used to load several type of distribution functions
+!------------------------------------------------------------------------------
+
+MODULE distrib
+ !
+ IMPLICIT NONE
+contains
+
+!---------------------------------------------------------------------------
+!> @author
+!> Trach Minh Tran EPFL/SPC
+!
+! DESCRIPTION:
+!>
+!> @brief Load a uniform distribution using the Hammersley's sequence (0<=y<=1).
+!> (nbase = 0 => Random sampling)
+!
+!> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+!> @param [out] y array containing the random variables.
+!---------------------------------------------------------------------------
+SUBROUTINE loduni(nbase, y)
+ !
+ ! Load a uniform distribution using the Hammersley's sequence.
+ ! (nbase = 0 => Random sampling)
+ !
+ INTEGER, INTENT(in) :: nbase
+ DOUBLE PRECISION, INTENT(inout) :: y(:)
+ INTEGER :: n, i
+ !
+ n = SIZE(y)
+ !
+ SELECT CASE (nbase)
+ CASE(0)
+ CALL RANDOM_NUMBER(y)
+ CASE(1)
+ DO i=1,n
+ y(i) = (i-0.5_db)/n
+ END DO
+ CASE(2:)
+ DO i=1,n
+ y(i) = rev(nbase,i)
+ END DO
+ CASE default
+ WRITE(*,'(a,i5)') 'Invalid value of NBASE =', nbase
+ END SELECT
+ !
+ END SUBROUTINE loduni
+
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Trach Minh Tran EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Load a gaussian distribution using a uniform distribution according to the Hammersley's sequence.
+ !> (nbase = 0 => Random sampling)
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [out] y array containing the random variables.
+ !---------------------------------------------------------------------------
+ SUBROUTINE lodgaus(nbase, y)
+ !
+ ! Sample y from the Gauss distributrion
+ !
+ DOUBLE PRECISION, INTENT(inout) :: y(:)
+ INTEGER, INTENT(in) :: nbase
+ !
+ INTEGER :: n, i, iflag
+ DOUBLE PRECISION :: r(SIZE(y))
+ DOUBLE PRECISION :: t
+ !
+ DOUBLE PRECISION :: c0, c1, c2
+ DOUBLE PRECISION :: d1, d2, d3
+ DATA c0, c1, c2/2.515517_db, 0.802853_db, 0.010328_db/
+ DATA d1, d2, d3/1.432788_db, 0.189269_db, 0.001308_db/
+ !
+ n = SIZE(y)
+ CALL loduni(nbase, r)
+ r = 1.0E-5 + 0.99998*r
+ !
+ DO i=1,n
+ iflag = 1
+ IF (r(i) .GT. 0.5) THEN
+ r(i) = 1.0 - r(i)
+ iflag = -1
+ END IF
+ t = SQRT(LOG(1.0/(r(i)*r(i))))
+ y(i) = t - (c0+c1*t+c2*t**2) / (1.0+d1*t+d2*t**2+d3*t**3)
+ y(i) = y(i) * iflag
+ END DO
+ y = y - SUM(y)/REAL(n)
+ END SUBROUTINE lodgaus
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Guillaume Le Bars EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Load the array y according to a probability distribution function proportional to 1/r
+ !> between ra and rb
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [in] ra Lower limit for the values in y
+ !> @param [in] rb Upper limit for the values in y
+ !> @param [out] y array containing the random variables.
+ !---------------------------------------------------------------------------
+ SUBROUTINE lodinvr(nbase, y, ra, rb)
+ !
+ !
+ DOUBLE PRECISION, INTENT(out) :: y(:)
+ INTEGER, INTENT(in) :: nbase
+ DOUBLE PRECISION, INTENT(in) :: rb, ra
+ !
+ DOUBLE PRECISION :: r(SIZE(y))
+ !
+ CALL loduni(nbase, r)
+ r=r*log(rb/ra)
+ y=ra*exp(r)
+ END SUBROUTINE lodinvr
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Guillaume Le Bars EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Load the array y according to a probability distribution function proportional to r
+ !> between ra and rb
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [in] ra Lower limit for the values in y
+ !> @param [in] rb Upper limit for the values in y
+ !> @param [out] y array containing the random variables.
+ !---------------------------------------------------------------------------
+ SUBROUTINE lodlinr(nbase, y, ra, rb)
+ DOUBLE PRECISION, INTENT(out) :: y(:)
+ INTEGER, INTENT(in) :: nbase
+ DOUBLE PRECISION, INTENT(in) :: rb, ra
+ !
+ DOUBLE PRECISION :: r(SIZE(y))
+ !
+ CALL loduni(nbase, r)
+ y=ra+sqrt(r)*(rb-ra)
+ END SUBROUTINE lodlinr
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Guillaume Le Bars EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Load the array y according to a uniform probability distribution function
+ !> between ra and rb
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [in] ra Lower limit for the values in y
+ !> @param [in] rb Upper limit for the values in y
+ !> @param [out] y array containing the random variables.
+ !---------------------------------------------------------------------------
+ SUBROUTINE lodunir(nbase, y, ra, rb)
+ DOUBLE PRECISION, INTENT(out) :: y(:)
+ INTEGER, INTENT(in) :: nbase
+ DOUBLE PRECISION, INTENT(in) :: rb, ra
+ !
+ DOUBLE PRECISION :: r(SIZE(y))
+ !
+ CALL loduni(nbase, r)
+ y=ra+(rb-ra)*r
+ END SUBROUTINE lodunir
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Guillaume Le Bars EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Load the array y according to a gaussian probability distribution function
+ !> around the mean of rb and ra and a sigma of (rb-ra)/10
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [in] ra Lower limit for the values in y
+ !> @param [in] rb Upper limit for the values in y
+ !> @param [out] y array containing the random variables.
+ !---------------------------------------------------------------------------
+ SUBROUTINE lodgausr(nbase, y, ra, rb)
+ DOUBLE PRECISION, INTENT(out) :: y(:)
+ INTEGER, INTENT(in) :: nbase
+ DOUBLE PRECISION, INTENT(in) :: rb, ra
+ !
+ DOUBLE PRECISION :: r(SIZE(y))
+ !
+ CALL lodgaus(nbase, r)
+ y=0.5*(rb+ra)+ 0.1*(rb-ra)*r
+ END SUBROUTINE lodgausr
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Trach Minh Tran EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Return an element of the Hammersley's sequence
+ !
+ !> @param [in] nbase Base of the Hammersley's sequence. (0 => Random)
+ !> @param [in] i Index of the sequence.
+ !> @param [out] rev Returned element of the Hammersley's sequence
+ !---------------------------------------------------------------------------
+ DOUBLE PRECISION FUNCTION rev(nbase,i)
+ !
+ INTEGER, INTENT(IN) :: nbase ! Base of the Hammersley's sequence (IN)
+ INTEGER, INTENT(IN) :: i ! Index of the sequence (IN)
+ !
+ ! Local vars
+ INTEGER :: j1, j2
+ DOUBLE PRECISION :: xs, xsi
+ !-----------------------------------------------------------------------
+ xs = 0.0
+ xsi = 1.0
+ j2 = i
+ DO
+ xsi = xsi/nbase
+ j1 = j2/nbase
+ xs = xs + (j2-nbase*j1)*xsi
+ j2 = j1
+ IF( j2.LE.0 ) EXIT
+ END DO
+ rev = xs
+ END FUNCTION rev
+ !---------------------------------------------------------------------------
+ !> @author
+ !> Trach Minh Tran EPFL/SPC
+ !
+ ! DESCRIPTION:
+ !>
+ !> @brief Modified Bessel functions of the first kind of the first order 1
+ !
+ !---------------------------------------------------------------------------
+
+ FUNCTION bessi1(x)
+ DOUBLE PRECISION :: bessi1,x
+ DOUBLE PRECISION :: ax
+ DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
+ SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
+ DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
+ DATA q1,q2,q3,q4,q5,q6,q7,q8,q9 /0.39894228d0, -0.3988024d-1, -0.362018d-2, 0.163801d-2,-0.1031555d-1, &
+ & 0.2282967d-1, -0.2895312d-1, 0.1787654d-1,-0.420059d-2/
+ if (abs(x).lt.3.75) then
+ y=(x/3.75)**2
+ bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
+ else
+ ax=abs(x)
+ y=3.75/ax
+ bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*(q7+y*(q8+y*q9))))))))
+ if(x.lt.0.)bessi1=-bessi1
+ endif
+ return
+ END FUNCTION bessi1
+
+END MODULE distrib
\ No newline at end of file