Homec4science
Diffusion FENNECS: Finite Element Non-Neutral Electron Cloud Simulator (geom_testpardiso) Browse

fennecs/src/beam_mod.f90
a2847b9464fageom_testpardiso

Last Change
Raw File

beam_mod.f90
View Options

!------------------------------------------------------------------------------
! 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 :: Nploc !< Local number of simulated particles
INTEGER :: Nptot !< Total number of simulated particles
REAL(kind=db) :: m !< Particle mass
REAL(kind=db) :: q !< Particle charge
REAL(kind=db) :: weight !< Number of particles represented by one macro-particle
REAL(kind=db) :: qmRatio !< Charge over mass ratio
REAL(kind=db) :: H0
REAL(kind=db) :: P0
REAL(kind=db) :: temperature
LOGICAL :: Davidson=.false.
LOGICAL :: is_test= .false.
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
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: R !< radial coordinates of the particles
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: Z !< longitudinal coordinates of the particles
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: THET !< azimuthal coordinates of the particles
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: WZ !< axial radial relative distances to the left grid line
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: WR !< radial relative distances to the bottom grid line
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: pot !< Electric potential
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: Er !< Radial Electric field
REAL(kind=db), DIMENSION(:), ALLOCATABLE :: Ez !< Axial electric field
REAL(kind=db), DIMENSION(:),POINTER:: UR !< normalized radial velocity at the current time step
REAL(kind=db), DIMENSION(:),POINTER:: URold !< normalized radial velocity at the previous time step
REAL(kind=db), DIMENSION(:),POINTER:: UTHET !< normalized azimuthal velocity at the current time step
REAL(kind=db), DIMENSION(:),POINTER:: UTHETold !< normalized azimuthal velocity at the previous time step
REAL(kind=db), DIMENSION(:),POINTER:: UZ !< normalized axial velocity at the current time step
REAL(kind=db), DIMENSION(:),POINTER:: UZold !< normalized axial velocity at the previous time step
REAL(kind=db), DIMENSION(:),POINTER:: Gamma !< Lorentz factor at the current time step
REAL(kind=db), DIMENSION(:),POINTER:: Gammaold !< Lorentz factor at the previous time step
LOGICAL:: collected !< Stores if the particles data have been collected to MPI root process during this timestep
END TYPE particles
!
!TYPE(particles) :: parts !< Storage for all the particles
!SAVE :: parts
TYPE(particles), DIMENSION(:), ALLOCATABLE, SAVE :: partslist
! Diagnostics (scalars)
REAL(kind=db) :: ekin=0 !< Total kinetic energy (J)
REAL(kind=db) :: epot=0 !< Total potential energy (J)
REAL(kind=db) :: etot=0 !< Current total energy (J)
REAL(kind=db) :: etot0=0 !< Initial total energy (J)
REAL(kind=db) :: loc_etot0=0 !< theoretical local total energy (J)
REAL(kind=db) :: Energies(4) !< (1) kinetic energy, (2) potential energy, (3) total energy and (4) gained/lossed energy due to gain or loss of particles (J)
INTEGER, DIMENSION(3), SAVE :: ireducerequest=MPI_REQUEST_NULL !< MPI requests used for the IREDUCE in the diagnostic routine
!
INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: Nplocs_all !< Array containing the local numbers of particles in each MPI process
!
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%Nploc = nparts
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))
p%partindex=-1
p%URold=0
p%UZold=0
p%UTHETold=0
p%rindex=0
p%zindex=0
p%WR=0
p%WZ=0
p%UR=0
p%UZ=0
p%UTHET=0
p%Z=0
p%R=0
p%THET=0
p%Gamma=1
p%Er=0
p%Ez=0
p%pot=0
p%gammaold=1
p%collected=.false.
p%Davidson=.false.
p%is_test=.false.
p%m=me
p%q=-elchar
p%qmRatio=p%q/p%m
p%weight=1.0_db
p%H0=0
p%P0=0
p%temperature=0
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, nbspecies, Zbounds
USE mpi
INTEGER:: i, j
REAL(kind=db), 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, uniform in Z and 1/R in R
CALL loaduniformRZ(partslist(1), VR, VZ, VTHET)
CASE(2) !Stable distribution from Davidson 4.95 p.119
CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodunir)
CASE(3) !Stable distribution from Davidson 4.95 p.119 but with constant distribution in R
CALL loadDavidson(partslist(1), VR, VZ, VTHET, lodinvr)
CASE(4) !Stable distribution from Davidson 4.95 p.119 but with gaussian distribution in R
CALL loadDavidson(partslist(1), 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(partslist(1), 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(partslist(1), VR, VZ, VTHET)
VZ = VZ/50
CASE(7) ! Distribution defined in separate input file
CALL loadPartFile(partslist(1), 1,VR,VZ,VTHET)
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
partslist(1)%partindex(i)=i
END DO
IF(nlclassical) THEN
partslist(1)%Gamma(1:nplasma)=1.0_db
ELSE
partslist(1)%Gamma(1:nplasma)=sqrt(1/(1-VR**2-VZ**2-VTHET**2))
END IF
! Normalization of the velocities
partslist(1)%UR(1:nplasma)=partslist(1)%Gamma(1:nplasma)*VR
partslist(1)%UZ(1:nplasma)=partslist(1)%Gamma(1:nplasma)*VZ
partslist(1)%UTHET(1:nplasma)=partslist(1)%Gamma(1:nplasma)*VTHET
DEALLOCATE(VZ, VR, VTHET)
CALL localisation(partslist(1))
IF(mpisize .gt. 1) THEN
CALL distribpartsonprocs(partslist(1))
END IF
DO i=2,nbspecies
CALL loadPartFile(partslist(i), i, VR, VZ, VTHET)
Do j=1,partslist(i)%Nploc
partslist(i)%partindex(j)=j
END DO
IF(nlclassical) THEN
partslist(i)%Gamma=1.0_db
ELSE
partslist(i)%Gamma=sqrt(1/(1-VR**2-VZ**2-VTHET**2))
END IF
! Normalization of the velocities
partslist(i)%UR = partslist(i)%Gamma*VR
partslist(i)%UZ = partslist(i)%Gamma*VZ
partslist(i)%UTHET= partslist(i)%Gamma*VTHET
DEALLOCATE(VZ, VR, VTHET)
CALL localisation(partslist(i))
END DO
IF(mpisize .gt. 1) THEN
DO i=1,nbspecies
CALL keep_mpi_self_parts(partslist(i), Zbounds)
END DO
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.
!
!> @param[in] p particles structure
!
!> @author Guillaume Le Bars EPFL/SPC
!---------------------------------------------------------------------------
SUBROUTINE bound(p)
USE basic, ONLY: zgrid, nz, Zbounds, mpirank, partperiodic, step, leftproc, rightproc
IMPLICIT NONE
type(particles), INTENT(INOUT):: p
INTEGER :: i, rsendnbparts, lsendnbparts, nblostparts
INTEGER :: receivednbparts, partdiff, lostindex, sentindex
INTEGER, DIMENSION(p%Nploc) :: sendhole
INTEGER, DIMENSION(p%Nploc) :: losthole
LOGICAL:: leftcomm, rightcomm, sent
INTEGER, ALLOCATABLE:: partstoremove(:)
rsendnbparts=0
lsendnbparts=0
nblostparts=0
losthole=0
sendhole=0
receivednbparts=0
! We communicate with the left processus
leftcomm = leftproc .ne. -1
! We communicate with the right processus
rightcomm = rightproc .ne. -1
IF (p%Nploc .gt. 0) THEN
! Boundary condition at z direction
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
DO i=1,p%Nploc
! If the particle is to the right of the local simulation space, it is sent to the right MPI process
IF (p%Z(i) .ge. zgrid(Zbounds(mpirank+1))) THEN
!$OMP CRITICAL (nbparts)
IF(rightcomm) THEN
rsendnbparts=rsendnbparts+1
sendhole(lsendnbparts+rsendnbparts)=i
DO WHILE (p%Z(i) .GT. zgrid(nz))
p%Z(i) = p%Z(i) - zgrid(nz) + zgrid(0)
END DO
ELSE
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 (p%Z(i) .lt. zgrid(Zbounds(mpirank))) THEN
!$OMP CRITICAL (nbparts)
IF(leftcomm) THEN
lsendnbparts=lsendnbparts+1
sendhole(lsendnbparts+rsendnbparts)=-i
DO WHILE (p%Z(i) .LT. zgrid(0))
p%Z(i) = p%Z(i) + zgrid(nz) - zgrid(0)
END DO
ELSE
nblostparts=nblostparts+1
losthole(nblostparts)=i
END IF
!$OMP END CRITICAL (nbparts)
END IF
END DO
!$OMP END PARALLEL DO
END IF
IF(mpisize .gt. 1) THEN
! We send the particles leaving the local simulation space to the closest neighbour
CALL particlescommunication(p, lsendnbparts, rsendnbparts, sendhole, receivednbparts)
END IF
! If the boundary conditions are not periodic, we delete the corresponding particles
IF(nblostparts .gt. 0 .and. step .ne. 0) THEN
DO i=nblostparts,1,-1
CALL delete_part(p, losthole(i), .false. )
END DO
WRITE(*,'(i8.2,a,i4.2)') nblostparts, " particles lost in z on process: ", mpirank
END IF
! computes if we received less particles than we sent
partdiff=max(lsendnbparts+rsendnbparts-receivednbparts,0)
ALLOCATE(partstoremove(nblostparts+partdiff))
IF(nblostparts.gt.0 .and. partdiff .gt. 0) THEN
sentindex=receivednbparts+1
lostindex=1
DO i=1,nblostparts+partdiff
IF(sentindex .le. lsendnbparts+rsendnbparts) THEN
IF(losthole(lostindex) .eq. 0) THEN
sent= .true.
ELSE IF(abs(sendhole(sentindex)) .lt. abs(losthole(lostindex))) THEN
sent=.true.
ELSE
sent=.false.
END IF
ELSE
sent=.false.
END IF
IF(sent) THEN
partstoremove(i)=abs(sendhole(sentindex))
sentindex=sentindex+1
ELSE
partstoremove(i)=abs(losthole(lostindex))
lostindex=lostindex+1
END IF
END DO
ELSEIF(nblostparts .gt. 0) THEN
partstoremove=abs(losthole(1:nblostparts))
ELSEIF(partdiff .gt. 0) THEN
partstoremove=abs(sendhole(receivednbparts+1:lsendnbparts+rsendnbparts))
ELSE
RETURN
END IF
! If we received less particles than we sent, or lost particles we fill the remaining holes with the particles from the end of the
! parts arrays
DO i=nblostparts+partdiff,1, -1
CALL move_part(p, p%Nploc, partstoremove(i))
p%Nploc = p%Nploc-1
END DO
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.
!> @param[in] p particles structure
!---------------------------------------------------------------------------
SUBROUTINE localisation(p)
USE basic, ONLY: zgrid, rgrid, dz, nr, nnr, dr
type(particles), INTENT(INOUT):: p
INTEGER :: i, nblostparts
INTEGER, DIMENSION(p%Nploc) :: losthole
REAL(kind=db):: invdz, invdr(3)
losthole=0
nblostparts=0
invdz=1/dz
invdr=1/dr
IF (p%Nploc .gt. 0) THEN
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
DO i=1,p%Nploc
p%zindex(i)=(p%Z(i)-zgrid(0))*invdz
IF (p%R(i) .GT. rgrid(0) .AND. p%R(i) .LT. rgrid(nnr(1))) THEN
p%rindex(i)=(p%R(i)-rgrid(0))*invdr(1)
ELSE IF(p%R(i) .GE. rgrid(nnr(1)) .AND. p%R(i) .LT. rgrid(nnr(1)+nnr(2))) THEN
p%rindex(i)=(p%R(i)-rgrid(nnr(1)))*invdr(2)+nnr(1)
ELSE IF(p%R(i) .GE. rgrid(nnr(1)+nnr(2)) .AND. p%R(i) .LT. rgrid(nr)) THEN
p%rindex(i)=(p%R(i)-rgrid(nnr(1)+nnr(2)))*invdr(3)+nnr(1)+nnr(2)
ELSE
! If the particle is outside of the simulation space in the r direction, it is deleted.
!$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 i=nblostparts,1,-1
!WRITE(*,'(a,i8.8,a,i4.2,a,3(1pe12.3))') "Particle: ", losthole(i) , " of process: ", mpirank, " is out of bound in r: ", p%R(losthole(i))*rnorm, rgrid(0)*rnorm, rgrid(nr)*rnorm
CALL delete_part(p,losthole(i))
END DO
WRITE(*,'(i6.2,a,i6.2)') nblostparts, " particles lost in r on process: ", mpirank
END IF
!$OMP PARALLEL DO SIMD DEFAULT(SHARED)
DO i=1,p%Nploc
p%WZ(i)=(p%Z(i)-zgrid(p%zindex(i)))/dz;
p%WR(i)=(p%R(i)-rgrid(p%rindex(i)))/(rgrid(p%rindex(i)+1)-rgrid(p%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.
!
!> @param[in] p The particles structure being updated
!---------------------------------------------------------------------------
SUBROUTINE comp_velocity(p)
!
! Computes the new velocity of the particles due to Lorentz force
!
USE basic, ONLY : nlclassical
type(particles), INTENT(INOUT):: p
! Store old Velocities
CALL swappointer(p%UZold, p%UZ)
CALL swappointer(p%URold, p%UR)
CALL swappointer(p%UTHETold, p%UTHET)
CALL swappointer(p%Gammaold, p%Gamma)
IF (nlclassical) THEN
CALL comp_velocity_fun(p, gamma_classical)
ELSE
CALL comp_velocity_fun(p, 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$
!> @param[in] p The particles structure being updated
!---------------------------------------------------------------------------
SUBROUTINE comp_velocity_fun(p, gamma)
!
! Computes the new velocity of the particles due to Lorentz force
!
USE basic, ONLY : bnorm, dt, BZ, BR, nz
interface
REAL(kind=db) FUNCTION gamma(UZ, UR, UTHET)
USE constants
REAL(kind=db), INTENT(IN):: UR,UZ,UTHET
end FUNCTION
end interface
type(particles), INTENT(INOUT):: p
REAL(kind=db) :: tau
REAL(kind=db):: 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
tau=p%qmRatio*bnorm*0.5*dt
IF (p%Nploc .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,p%Nploc
J1=(p%rindex(i))*(nz+1) + p%zindex(i)+1
J2=(p%rindex(i))*(nz+1) + p%zindex(i)+2
J3=(p%rindex(i)+1)*(nz+1)+p%zindex(i)+1
J4=(p%rindex(i)+1)*(nz+1)+p%zindex(i)+2
! Interpolation for magnetic field
BRZ=(1-p%WZ(i))*(1-p%WR(i))*Bz(J4) &
& +p%WZ(i)*(1-p%WR(i))*Bz(J3) &
& +(1-p%WZ(i))*p%WR(i)*Bz(J2) &
& +p%WZ(i)*p%WR(i)*Bz(J1)
BRR=(1-p%WZ(i))*(1-p%WR(i))*Br(J4) &
& +p%WZ(i)*(1-p%WR(i))*Br(J3) &
& +(1-p%WZ(i))*p%WR(i)*Br(J2) &
& +p%WZ(i)*p%WR(i)*Br(J1)
! First half of electric pulse
p%UZ(i)=p%UZold(i)+p%Ez(i)*tau
p%UR(i)=p%URold(i)+p%ER(i)*tau
p%Gamma(i)=gamma(p%UZ(i), p%UR(i), p%UTHETold(i))
! Rotation along magnetic field
ZBZ=tau*BRZ/p%Gamma(i)
ZBR=tau*BRR/p%Gamma(i)
ZPZ=p%UZ(i)-ZBR*p%UTHETold(i) !u'_{z}
ZPR=p%UR(i)+ZBZ*p%UTHETold(i) !u'_{r}
ZPTHET=p%UTHETold(i)+(ZBR*p%UZ(i)-ZBZ*p%UR(i)) !u'_{theta}
SQR=1+ZBZ*ZBZ+ZBR*ZBR
ZBZ2=2*ZBZ/SQR
ZBR2=2*ZBR/SQR
p%UZ(i)=p%UZ(i)-ZBR2*ZPTHET !u+_{z}
p%UR(i)=p%UR(i)+ZBZ2*ZPTHET !u+_{r}
p%UTHET(i)=p%UTHETold(i)+(ZBR2*ZPZ-ZBZ2*ZPR) !u+_{theta}
! Second half of acceleration
p%UZ(i)=p%UZ(i)+p%EZ(i)*tau
p%UR(i)=p%UR(i)+p%ER(i)*tau
! Final computation of the Lorentz factor
p%Gamma(i)=gamma(p%UZ(i), p%UR(i), p%UTHET(i))
END DO
!$OMP END PARALLEL DO SIMD
END IF
p%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 REAL(kind=db) FUNCTION gamma_classical(UZ, UR, UTHET)
#if __INTEL_COMPILER > 1700
!$OMP declare simd(gamma_classical)
#endif
REAL(kind=db), INTENT(IN):: UR,UZ,UTHET
gamma_classical=1.0
END FUNCTION 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 REAL(kind=db) FUNCTION gamma_relativistic(UZ, UR, UTHET)
#if __INTEL_COMPILER > 1700
!$OMP declare simd(gamma_relativistic)
#endif
REAL(kind=db), INTENT(IN):: UR,UZ,UTHET
gamma_relativistic=sqrt(1+UZ**2+UR**2+UTHET**2)
END FUNCTION gamma_relativistic
!---------------------------------------------------------------------------
!> @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.
!
!> @param[in] p The particles structure being updated
!---------------------------------------------------------------------------
SUBROUTINE push(p)
Use basic, ONLY: dt, tnorm
type(particles), INTENT(INOUT):: p
REAL(kind=db):: XP, YP, COSA, SINA, U1, U2, ALPHA
INTEGER :: i
IF (p%Nploc .NE. 0) THEN
!$OMP PARALLEL DO SIMD DEFAULT(SHARED) PRIVATE(XP, YP, COSA, SINA, U1, U2, ALPHA)
DO i=1,p%Nploc
! Local Cartesian coordinates
XP=p%R(i)+dt/tnorm*p%UR(i)/p%Gamma(i)
YP=dt/tnorm*p%UTHET(i)/p%Gamma(i)
! Conversion to cylindrical coordiantes
p%Z(i)=p%Z(i)+dt/tnorm*p%UZ(i)/p%Gamma(i)
p%R(i)=sqrt(XP**2+YP**2)
! Computation of the rotation angle
IF (p%R(i) .EQ. 0) THEN
COSA=1
SINA=0
ALPHA=0
ELSE
COSA=XP/p%R(i)
SINA=YP/p%R(i)
ALPHA=asin(SINA)
END IF
! New azimuthal position
p%THET(i)=MOD(p%THET(i)+ALPHA,2*pi)
! Velocity in rotated reference frame
U1=COSA*p%UR(i)+SINA*p%UTHET(i)
U2=-SINA*p%UR(i)+COSA*p%UTHET(i)
p%UR(i)=U1
p%UTHET(i)=U2
END DO
!$OMP END PARALLEL DO SIMD
END IF
p%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 keeps track of the reference energy and the number of particle per mpi node.
!
!---------------------------------------------------------------------------
SUBROUTINE diagnostics
!
! Compute energies
!
USE constants, ONLY: vlight
USE basic, ONLY: phinorm, cstep, nlclassical, ierr, step, nlend,&
& itparts
INTEGER :: i
INTEGER:: stat(MPI_STATUS_SIZE,3)
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,partslist(1)%Nploc
! Potential energy
epot=epot+0.5*partslist(1)%q*partslist(1)%weight*(partslist(1)%pot(i))*phinorm
! Kinetic energy
IF(.not. nlclassical) THEN
ekin=ekin+partslist(1)%m*partslist(1)%weight*vlight**2*(partslist(1)%Gamma(i)-1)
ELSE
ekin=ekin+0.5*partslist(1)%m*partslist(1)%weight*vlight**2*(partslist(1)%UR(i)**2&
& +partslist(1)%UZ(i)**2&
& +partslist(1)%UTHET(i)**2)
END IF
END DO
!$OMP END PARALLEL DO SIMD
! Shift to Etot at cstep=1 (not valable yet at cstep=0!)
IF(cstep.EQ.0 ) THEN
! Compute the local total energy
loc_etot0 = epot+ekin
etot0=0
END IF
!etot=loc_etot0
! Compute the total energy
etot=epot+ekin
Energies=(/ekin,epot,ekin+epot,loc_etot0/)
! The computed energy is sent to the root process
IF(mpisize .gt.1) THEN
IF(mpirank .eq.0 ) THEN
!CALL MPI_REDUCE(MPI_IN_PLACE, epot, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
!CALL MPI_REDUCE(MPI_IN_PLACE, ekin, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
!CALL MPI_REDUCE(etot, etot0, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
CALL MPI_REDUCE(MPI_IN_PLACE, Energies, 4, db_type, db_sum_op, &
& 0, MPI_COMM_WORLD, ierr)
etot0=etot0+Energies(4)
ekin=Energies(1)
epot=Energies(2)
etot=Energies(3)
ELSE
!CALL MPI_REDUCE(epot, epot, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
!CALL MPI_REDUCE(ekin, ekin, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
!CALL MPI_REDUCE(etot, etot0, 1, db_type, db_sum_op, &
!& 0, MPI_COMM_WORLD, ierr)
CALL MPI_REDUCE(Energies, Energies, 4, db_type, db_sum_op, &
& 0, MPI_COMM_WORLD, ierr)
END IF
loc_etot0=0
ELSE
etot0=loc_etot0
END IF
! Send the local number of particles on each node to the root process
IF(mpisize .gt. 1) THEN
Nplocs_all(mpirank)=partslist(1)%Nploc
IF(mpirank .eq.0 ) THEN
CALL MPI_gather(MPI_IN_PLACE, 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,&
& 0, MPI_COMM_WORLD, ierr)
partslist(1)%Nptot=sum(Nplocs_all)
ELSE
CALL MPI_gather(Nplocs_all(mpirank), 1, MPI_INTEGER, Nplocs_all, 1, MPI_INTEGER,&
& 0, MPI_COMM_WORLD, ierr)
END IF
ELSE
partslist(1)%Nptot=partslist(1)%Nploc
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(partslist(1))
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(p)
USE basic, ONLY: mpirank, mpisize, ierr
type(particles), INTENT(INOUT):: p
INTEGER, DIMENSION(:), ALLOCATABLE :: displs, Nploc
INTEGER:: i
IF(p%collected) RETURN ! exit subroutine if particles have already been collected during this time step
ALLOCATE(Nploc(0:mpisize-1))
ALLOCATE(displs(0:mpisize-1))
displs=0
Nploc(mpirank)=p%Nploc
CALL MPI_Allgather(MPI_IN_PLACE, 1, MPI_INTEGER, Nploc, 1, MPI_INTEGER,&
& MPI_COMM_WORLD, ierr)
p%Nptot=sum(Nploc)
IF(p%Nptot .eq. 0 ) THEN
p%collected=.true.
RETURN
END IF
IF(mpirank .ne. 0) THEN
! Send Particles informations to root process
CALL MPI_Gatherv(p%Z, Nploc(mpirank), db_type, p%Z, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%R, Nploc(mpirank), db_type, p%R, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%THET, Nploc(mpirank), db_type, p%THET, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%UR, Nploc(mpirank), db_type, p%UR, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%UZ, Nploc(mpirank), db_type, p%UZ, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%UTHET, Nploc(mpirank), db_type, p%UTHET, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%pot, Nploc(mpirank), db_type, p%pot, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%Rindex, Nploc(mpirank), MPI_INTEGER, p%Rindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%Zindex, Nploc(mpirank), MPI_INTEGER, p%Zindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(p%partindex, Nploc(mpirank), MPI_INTEGER, p%partindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
ELSE
Do i=1,mpisize-1
displs(i)=displs(i-1)+Nploc(i-1)
END DO
IF(p%Nptot .gt. size(p%R,1)) THEN
CALL change_parts_allocation(p,p%Nptot-size(P%R,1))
END IF
! Receive particle information from all processes
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%Z, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%R, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%THET, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%UR, Nploc, displs,&
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%UZ, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%UTHET, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), db_type, p%pot, Nploc, displs, &
& db_type, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), MPI_INTEGER, p%Rindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), MPI_INTEGER, p%Zindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
CALL MPI_Gatherv(MPI_IN_PLACE, Nploc(mpirank), MPI_INTEGER, p%partindex, Nploc, displs, &
& MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
p%partindex(sum(Nploc)+1:)=-1
END IF
p%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(p)
!! Computes the velocity at time -dt/2 from velocities computed at time 0
!
USE basic, ONLY : bnorm, dt, BZ, BR, nlclassical, phinorm, nz, distribtype, vnorm
type(particles), INTENT(INOUT):: p
REAL(kind=db) :: tau, BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, &
& SQR, Vperp, v2
INTEGER :: J1, J2, J3, J4, i
REAL(kind=db), 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 .or. p%Davidson) THEN
ALLOCATE(VR(p%Nploc),VZ(p%Nploc),VTHET(p%Nploc))
CALL loduni(7,VZ)
VZ=VZ*2*pi
VTHET=p%UTHET/p%Gamma*vnorm
DO i=1,p%Nploc
Vperp=sqrt(MAX(2*p%H0/p%m-2*p%qmRatio*p%pot(i)*phinorm-VTHET(i)**2,0.0_db))
VR(i)=Vperp*sin(VZ(i))
VZ(i)=Vperp*cos(VZ(i))
IF(nlclassical) THEN
p%Gamma(i)=1
ELSE
v2=VR(i)**2+VZ(i)**2+VTHET(i)**2
p%Gamma(i)=sqrt(1/(1-v2/vnorm**2))
END IF
p%UR(i)=p%Gamma(i)*VR(i)/vnorm
p%UZ(i)=p%Gamma(i)*VZ(i)/vnorm
p%UTHET(i)=p%Gamma(i)*VTHET(i)/vnorm
END DO
DEALLOCATE(VR,VZ,VTHET)
RETURN
END IF
! Normalised time increment
!tau=-omegac/2/omegap*dt/tnorm
tau=p%qmRatio*bnorm*0.5*dt
! Store old Velocities
CALL swappointer(p%UZold, p%UZ)
CALL swappointer(p%URold, p%UR)
CALL swappointer(p%UTHETold, p%UTHET)
CALL swappointer(p%Gammaold, p%Gamma)
IF (p%Nploc .NE. 0) THEN
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,J1,J2,J3,J4,BRZ, BRR, ZBR, ZBZ, ZPR, ZPZ, ZPTHET, SQR)
DO i=1,p%Nploc
! Compute the particle linear indices for the magnetic field interpolation
J1=(p%rindex(i))*(nz+1)+p%zindex(i)+1
J2=J1+1
J3=(p%rindex(i)+1)*(nz+1)+p%zindex(i)+1
J4=J3+1
! Interpolation for magnetic field
BRZ=(1-p%WZ(i))*(1-p%WR(i))*Bz(J4) &
& +p%WZ(i)*(1-p%WR(i))*Bz(J3) &
& +(1-p%WZ(i))*p%WR(i)*Bz(J2) &
& +p%WZ(i)*p%WR(i)*Bz(J1)
BRR=(1-p%WZ(i))*(1-p%WR(i))*Br(J4) &
& +p%WZ(i)*(1-p%WR(i))*Br(J3) &
& +(1-p%WZ(i))*p%WR(i)*Br(J2) &
& +p%WZ(i)*p%WR(i)*Br(J1)
! Half inverse Rotation along magnetic field
ZBZ=tau*BRZ/p%Gammaold(i)
ZBR=tau*BRR/p%Gammaold(i)
SQR=1+ZBZ*ZBZ+ZBR*ZBR
ZPZ=(p%UZold(i)-ZBR*p%UTHETold(i))/SQR !u-_{z}
ZPR=(p%URold(i)+ZBZ*p%UTHETold(i))/SQR !u-_{r}
ZPTHET=p%UTHETold(i)+(ZBR*p%UZold(i)-ZBZ*p%URold(i))/SQR !u-_{theta}
p%UZ(i)=ZPZ
p%UR(i)=ZPR
p%UTHET(i)=ZPTHET
! half of decceleration
p%UZ(i)=p%UZ(i)+p%Ez(i)*tau
p%UR(i)=p%UR(i)+p%Er(i)*tau
IF(.not. nlclassical) THEN
p%Gamma(i)=sqrt(1+p%UZ(i)**2+p%UR(i)**2+p%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(p)
! 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
TYPE(particles), INTENT(INOUT):: p
INTEGER:: k, i, nbparts
REAL(kind=db):: 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(p%Nploc)/REAL(mpisize))
Zmin=MINVAL(p%Zindex(1:p%Nploc))
Zmax=MAXVAL(p%Zindex(1:p%Nploc))
Zperproc=(Zmax-Zmin)/mpisize
IF(Zmax .eq. 0) Zmax=nz
DO k=1,p%Nploc
zindex=p%Zindex(k)
partspercol(zindex)=partspercol(zindex)+1
END DO
IF (Zperproc .eq. 0) THEN
!! No particles are present initially
Zperproc=nz/mpisize
Zmin=0
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
ELSE
i=0
DO k=1,mpisize-1
nbparts=0
DO WHILE(nbparts<0.99*idealnbpartsperproc .and. i .lt. Zmax)
nbparts=nbparts+partspercol(i)
i=i+1
END DO
Zbounds(k)=i
END DO
END IF
partindexstart=1
totparts=0
partindexlast=p%Nploc
DO k=0,mpisize-1
Nplocs_all(k)=SUM(partspercol(Zbounds(k):Zbounds(k+1)-1))
END DO
WRITE(*,*) mpirank, " Zbounds: ", Zbounds(mpirank), Zbounds(mpirank+1), " nptot", Nplocs_all(mpirank)
END SUBROUTINE distribpartsonprocs
SUBROUTINE keep_mpi_self_parts(p,Zbounds)
TYPE(particles),INTENT(INOUT):: p
INTEGER,INTENT(in)::Zbounds(0:)
INTEGER :: i, partstart, old_sum,ierr
partstart=1
p%Nploc=0
Do i=1,p%Nptot
IF(p%Zindex(i).ge.Zbounds(mpirank).and.p%Zindex(i).lt.Zbounds(mpirank+1)) THEN
p%Nploc=p%Nploc+1
CALL move_part(p,i,p%Nploc)
END IF
END DO
old_sum=p%Nptot
CALL MPI_REDUCE(p%Nploc, p%Nptot,1,MPI_INTEGER, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
IF(p%Nptot .ne. old_sum) WRITE(*,*) "Error in particle distribution kept: ", p%Nptot, "/",old_sum
END SUBROUTINE keep_mpi_self_parts
!_______________________________________________________________________________
!---------------------------------------------------------------------------
!> @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(p, lsendnbparts, rsendnbparts, sendholes, receivednbparts)
USE mpihelper, ONLY: particle_type
USE basic, ONLY: rightproc, leftproc, ierr
#ifdef _DEBUG
USE basic, ONLY: step
#endif
type(particles), INTENT(INOUT):: p
INTEGER, INTENT(in) :: lsendnbparts, rsendnbparts
INTEGER, INTENT(out) :: receivednbparts
INTEGER, INTENT(in) :: sendholes(:)
INTEGER, ASYNCHRONOUS :: rrecvnbparts=0, lrecvnbparts=0
INTEGER, ASYNCHRONOUS :: sendrequest(2), recvrequest(2)
INTEGER, ASYNCHRONOUS :: sendstatus(MPI_STATUS_SIZE,2), recvstatus(MPI_STATUS_SIZE,2)
TYPE(particle), ALLOCATABLE :: rrecvpartbuff(:), lrecvpartbuff(:), rsendpartbuff(:), lsendpartbuff(:) ! buffers to send and receive particle from left and right processes
INTEGER :: lsentnbparts, rsentnbparts
INTEGER :: lreceivednbparts, rreceivednbparts
lsentnbparts=lsendnbparts
rsentnbparts=rsendnbparts
sendrequest=MPI_REQUEST_NULL
recvrequest=MPI_REQUEST_NULL
lrecvnbparts=0
rrecvnbparts=0
! 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_Waitall(2,recvrequest(1:2), recvstatus(:,1:2), ierr)
recvrequest=MPI_REQUEST_NULL
lreceivednbparts=lrecvnbparts
rreceivednbparts=rrecvnbparts
! Re/allocate enough memory to store the incoming particles
ALLOCATE(rrecvpartbuff(rreceivednbparts))
ALLOCATE(lrecvpartbuff(lreceivednbparts))
! 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
ALLOCATE(rsendpartbuff(rsendnbparts))
ALLOCATE(lsendpartbuff(lsendnbparts))
! Copy the leaving particles to the corresponding send buffers
IF ( (lsendnbparts + rsendnbparts) .gt. 0) THEN
CALL AddPartSendBuffers(p, lsendnbparts, rsendnbparts, sendholes, lsendpartbuff, rsendpartbuff)
END IF
CALL MPI_Waitall(2,sendrequest(1:2), sendstatus(:,1:2), 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)
#ifdef _DEBUG
!WRITE(*,*)"snding ", lsendnbparts , " to left at step: ",step
#endif
END IF
IF( rsendnbparts .gt. 0) THEN
CALL MPI_ISEND(rsendpartbuff, rsendnbparts, particle_type, rightproc, 1, MPI_COMM_WORLD, sendrequest(2), ierr)
#ifdef _DEBUG
!WRITE(*,*)"snding ", rsendnbparts , " to right at step: ",step
#endif
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
#ifdef _DEBUG
!WRITE(*,*)"rcvd ", lreceivednbparts , " from left at step: ",step
#endif
END IF
IF ( rreceivednbparts .gt. 0) THEN
CALL MPI_Wait(recvrequest(2), recvstatus(:,2), 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
#ifdef _DEBUG
!WRITE(*,*)"rcvd ", rreceivednbparts , " from right at step: ",step
#endif
END IF
receivednbparts=rreceivednbparts+lreceivednbparts
IF(p%Nploc+receivednbparts-lsendnbparts-rsendnbparts .gt. size(p%R,1)) THEN
CALL change_parts_allocation(p,receivednbparts)
END IF
! Copy the incoming particles from the receive buffers to the simulation parts variable
CALL Addincomingparts(p, rreceivednbparts, lreceivednbparts, lsendnbparts+rsendnbparts, &
& sendholes, lrecvpartbuff, rrecvpartbuff)
! 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)
#ifdef _DEBUG
!WRITE(*,*)"sent ", lsentnbparts , " to left at step: ",step
#endif
END IF
IF( rsendnbparts .gt. 0) THEN
CALL MPI_Wait(sendrequest(2), sendstatus(:,2), ierr)
#ifdef _DEBUG
!WRITE(*,*)"sent ", rsentnbparts , " to right at step: ",step
#endif
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(p, rrecvnbparts, lrecvnbparts, sendnbparts, sendholes,lrecvpartbuff, rrecvpartbuff)
!
USE mpihelper
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(in) :: rrecvnbparts, lrecvnbparts, sendnbparts
INTEGER, INTENT(in) :: sendholes(:)
TYPE(particle), INTENT(IN) :: rrecvpartbuff(:), lrecvpartbuff(:)
INTEGER k,partpos
! 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
p%Nploc=p%Nploc+1
partpos=p%Nploc
END IF
CALL Insertincomingpart(p, 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
p%Nploc=p%Nploc+1
partpos=p%Nploc
END IF
CALL Insertincomingpart(p, lrecvpartbuff, k, partpos)
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(p, buffer, bufferindex, partsindex)
USE mpihelper
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(in) :: bufferindex, partsindex
TYPE(particle), DIMENSION(:), INTENT(in) :: buffer
p%partindex(partsindex) = buffer(bufferindex)%partindex
p%Rindex(partsindex) = buffer(bufferindex)%Rindex
p%Zindex(partsindex) = buffer(bufferindex)%Zindex
p%R(partsindex) = buffer(bufferindex)%R
p%Z(partsindex) = buffer(bufferindex)%Z
p%THET(partsindex) = buffer(bufferindex)%THET
p%UZ(partsindex) = buffer(bufferindex)%UZ
p%UR(partsindex) = buffer(bufferindex)%UR
p%UTHET(partsindex) = buffer(bufferindex)%UTHET
p%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(p, buffer, bufferindex, partsindex)
USE mpihelper
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(in) :: bufferindex, partsindex
TYPE(particle), DIMENSION(:), INTENT(inout) :: buffer
buffer(bufferindex)%partindex = p%partindex(partsindex)
buffer(bufferindex)%Rindex = p%Rindex(partsindex)
buffer(bufferindex)%Zindex = p%Zindex(partsindex)
buffer(bufferindex)%R = p%R(partsindex)
buffer(bufferindex)%Z = p%Z(partsindex)
buffer(bufferindex)%THET = p%THET(partsindex)
buffer(bufferindex)%UZ = p%UZ(partsindex)
buffer(bufferindex)%UR = p%UR(partsindex)
buffer(bufferindex)%UTHET = p%UTHET(partsindex)
buffer(bufferindex)%Gamma = p%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(p, lsendnbparts, rsendnbparts, sendholes, lsendpartbuff, rsendpartbuff)
!
USE mpihelper
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(in) :: lsendnbparts, rsendnbparts
INTEGER, INTENT(in) :: sendholes(:)
TYPE(particle), INTENT(OUT) :: rsendpartbuff(:), lsendpartbuff(:)
INTEGER:: partpos, k
INTEGER:: lsendpos, rsendpos
lsendpos=0
rsendpos=0
! 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(p, rsendpartbuff, rsendpos, partpos)
ELSE IF(sendholes(k) .LT. 0) THEN
lsendpos=lsendpos+1
CALL Insertsentpart(p, 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(p, index1, index2)
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(IN) :: index1, index2
REAL(kind=db):: 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= p%partindex(index1)
Gamma = p%Gamma(index1)
R = p%R(index1)
Z = p%Z(index1)
THET = p%THET(index1)
UR = p%UR(index1)
UTHET = p%UTHET(index1)
UZ = p%UZ(index1)
Rindex = p%Rindex(index1)
Zindex = p%Zindex(index1)
! Move part at index2 in part at index 1
p%partindex(index1)= p%partindex(index2)
p%Gamma(index1) = p%Gamma(index2)
p%R(index1) = p%R(index2)
p%Z(index1) = p%Z(index2)
p%THET(index1) = p%THET(index2)
p%UR(index1) = p%UR(index2)
p%UTHET(index1) = p%UTHET(index2)
p%UZ(index1) = p%UZ(index2)
p%Rindex(index1) = p%Rindex(index2)
p%Zindex(index1) = p%Zindex(index2)
! Move temporary values from part(index1) to part(index2)
p%partindex(index2)= partindex
p%Gamma(index2) = Gamma
p%R(index2) = R
p%Z(index2) = Z
p%THET(index2) = THET
p%UR(index2) = UR
p%UTHET(index2) = UTHET
p%UZ(index2) = UZ
p%Rindex(index2) = Rindex
p%Zindex(index2) = Zindex
END SUBROUTINE exchange_parts
SUBROUTINE change_parts_allocation(p, sizedifference)
implicit none
TYPE(particles), INTENT(INOUT):: p
INTEGER,INTENT(IN) :: sizedifference
CALL change_array_size_int(p%Rindex, sizedifference)
CALL change_array_size_int(p%Zindex, sizedifference)
CALL change_array_size_int(p%partindex, sizedifference)
CALL change_array_size_dp(p%ER,sizedifference)
CALL change_array_size_dp(p%EZ,sizedifference)
CALL change_array_size_dp(p%pot,sizedifference)
CALL change_array_size_dp(p%R,sizedifference)
CALL change_array_size_dp(p%Z,sizedifference)
CALL change_array_size_dp(p%THET,sizedifference)
CALL change_array_size_dp(p%WR,sizedifference)
CALL change_array_size_dp(p%WZ,sizedifference)
CALL change_array_size_dp_ptr(p%UR,sizedifference)
CALL change_array_size_dp_ptr(p%URold,sizedifference)
CALL change_array_size_dp_ptr(p%UZ,sizedifference)
CALL change_array_size_dp_ptr(p%UZold,sizedifference)
CALL change_array_size_dp_ptr(p%UTHET,sizedifference)
CALL change_array_size_dp_ptr(p%UTHETold,sizedifference)
CALL change_array_size_dp_ptr(p%Gamma,sizedifference)
CALL change_array_size_dp_ptr(p%Gammaold,sizedifference)
p%Nploc=MIN(p%Nploc,size(p%R))
END SUBROUTINE change_parts_allocation
SUBROUTINE change_array_size_dp(arr, sizedifference)
implicit none
REAL(kind=db), ALLOCATABLE, INTENT(INOUT):: arr(:)
INTEGER, INTENT(IN):: sizedifference
REAL(kind=db), ALLOCATABLE:: temp(:)
INTEGER:: current_size, new_size
if(allocated(arr)) THEN
current_size=size(arr)
new_size=current_size+sizedifference
ALLOCATE(temp(new_size))
temp(1:min(current_size,new_size))=arr(1:min(current_size,new_size))
DEALLOCATE(arr)
CALL move_alloc(temp, arr)
END IF
END SUBROUTINE change_array_size_dp
SUBROUTINE change_array_size_dp_ptr(arr, sizedifference)
implicit none
REAL(kind=db), POINTER, INTENT(INOUT):: arr(:)
INTEGER, INTENT(IN):: sizedifference
REAL(kind=db), POINTER:: temp(:)
INTEGER:: current_size, new_size
if(associated(arr)) THEN
current_size=size(arr)
new_size=current_size+sizedifference
ALLOCATE(temp(new_size))
temp(1:min(current_size,new_size))=arr(1:min(current_size,new_size))
DEALLOCATE(arr)
arr=> temp
END IF
END SUBROUTINE change_array_size_dp_ptr
SUBROUTINE change_array_size_int(arr, sizedifference)
implicit none
INTEGER, ALLOCATABLE, INTENT(INOUT):: arr(:)
INTEGER, INTENT(IN):: sizedifference
INTEGER, ALLOCATABLE:: temp(:)
INTEGER:: current_size, new_size
if(allocated(arr)) THEN
current_size=size(arr)
new_size=current_size+sizedifference
ALLOCATE(temp(new_size))
temp(1:min(current_size,new_size))=arr(1:min(current_size,new_size))
DEALLOCATE(arr)
CALL move_alloc(temp,arr)
END IF
END SUBROUTINE change_array_size_int
SUBROUTINE add_created_part(p, buffer)
USE bsplines
USE basic, ONLY: splrz, phinorm, nlclassical
IMPLICIT NONE
TYPE(particles), INTENT(INOUT):: p
TYPE(particle), ALLOCATABLE, INTENT(in) :: buffer(:)
INTEGER:: i, nptotinit, parts_size_increase, nb_added, newindex
nptotinit=p%Nploc+1
nb_added=size(buffer,1)
! if there is not enough space in the parts simulation buffer, increase the parst size
IF(p%Nploc + nb_added .gt. size(p%Z,1)) THEN
parts_size_increase=Max(floor(0.1*size(p%Z,1)),nb_added)
CALL change_parts_allocation(p, parts_size_increase)
END IF
newindex=MAXVAL(p%partindex)
DO i=1,nb_added
p%Nploc=p%Nploc+1
newindex=newindex+1
CALL Insertincomingpart(p, buffer,i,p%Nploc)
p%partindex(p%Nploc)=newindex
END DO
! Compute the energy added by these new particles for energy conservation diagnostic
IF(nb_added .gt. 0) THEN
CALL getgrad(splrz, p%Z(nptotinit:p%Nploc), p%R(nptotinit:p%Nploc), &
& p%pot(nptotinit:p%Nploc), p%EZ(nptotinit:p%Nploc), p%ER(nptotinit:p%Nploc))
p%EZ(nptotinit:p%Nploc)=-p%Ez(nptotinit:p%Nploc)
p%ER(nptotinit:p%Nploc)=-p%ER(nptotinit:p%Nploc)
loc_etot0=loc_etot0+p%q*p%weight*sum(p%pot(nptotinit:p%Nploc))*phinorm
IF(.not. nlclassical) THEN
loc_etot0=loc_etot0+sum(p%m*p%weight*vlight**2*(p%Gamma(nptotinit:p%Nploc)-1))
ELSE
loc_etot0=loc_etot0+0.5*p%m*p%weight*vlight**2*sum(p%UR(nptotinit:p%Nploc)**2 &
& +p%UZ(nptotinit:p%Nploc)**2 &
& +p%UTHET(nptotinit:p%Nploc)**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(p, index, replace)
!! This will destroy particle at the given index
USE constants, ONLY: vlight
USE bsplines
USE basic, ONLY: phinorm, nlclassical,splrz, step
TYPE(particles), INTENT(INOUT):: p
INTEGER, INTENT(IN) :: index
LOGICAL, OPTIONAL :: replace
LOGICAL:: repl
REAL(kind=db):: pot(2),er(2),ez(2)
IF(present(replace)) THEN
repl=replace
ELSE
repl=.true.
END IF
!Computes the potential at the particle position with phi_ext+phi_s
IF(index .le. p%Nploc) THEN
IF(.not. p%is_test) THEN
CALL getgrad(splrz, p%Z(index:index), p%R(index:index), pot, EZ, ER)
loc_etot0=loc_etot0-p%q*p%weight*(pot(1))*phinorm
IF(.not. nlclassical) THEN
loc_etot0=loc_etot0-p%m*p%weight*vlight**2*(p%Gamma(index)-1)
ELSE
loc_etot0=loc_etot0-0.5*p%m*p%weight*vlight**2*(p%UR(index)**2+p%UZ(index)**2+p%UTHET(index)**2)
END IF
END IF
IF(repl) THEN
! We fill the gap
CALL move_part(p, p%Nploc, index)
p%partindex(p%Nploc)=-1
! Reduce the total number of simulated parts
p%Nploc=p%Nploc-1
END IF
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 overwrite 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(p, sourceindex, destindex)
!! This will destroy particle at destindex
INTEGER, INTENT(IN) :: destindex, sourceindex
TYPE(particles), INTENT(INOUT)::p
IF(sourceindex .eq. destindex) RETURN
IF(sourceindex .le. 0 .or. destindex .le. 0) RETURN
! Move part at sourceindex in part at destindex
Call copy_part(p,sourceindex,destindex,p)
END SUBROUTINE move_part
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Copy particle with index sourceindex in particles sourcep to particle with index destindex in particles destp.
!> !WARNING! This will overwrite particle at destp(destindex).
!
!> @param [inout] sourcep Structure of source particles.
!> @param [in] sourceindex index in parts of the particle to move.
!> @param [in] destindex index in parts of the moved particle destination.
!> @param [inout] destp Structure of source particles.
!---------------------------------------------------------------------------
SUBROUTINE copy_part(sourcep, sourceindex, destindex, destp)
!! This will destroy particle at destindex
INTEGER, INTENT(IN) :: destindex, sourceindex
TYPE(particles), INTENT(IN)::sourcep
TYPE(particles), INTENT(INOUT)::destp
IF(sourceindex .le. 0 .or. destindex .le. 0) RETURN
IF( destindex .gt. size(destp%R,1)) RETURN
! Move part at sourceindex in part at destindex
destp%partindex(destindex)= sourcep%partindex(sourceindex)
destp%Gamma(destindex) = sourcep%Gamma(sourceindex)
destp%R(destindex) = sourcep%R(sourceindex)
destp%Z(destindex) = sourcep%Z(sourceindex)
destp%THET(destindex) = sourcep%THET(sourceindex)
destp%UR(destindex) = sourcep%UR(sourceindex)
destp%UTHET(destindex) = sourcep%UTHET(sourceindex)
destp%UZ(destindex) = sourcep%UZ(sourceindex)
destp%Rindex(destindex) = sourcep%Rindex(sourceindex)
destp%Zindex(destindex) = sourcep%Zindex(sourceindex)
END SUBROUTINE copy_part
!________________________________________________________________________________
SUBROUTINE destroy_parts(p)
TYPE(particles) :: p
p%Nploc=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
!
INTEGER:: i
Do i=1,size(partslist,1)
CALL destroy_parts(partslist(i))
END DO
!
END SUBROUTINE clean_beam
!________________________________________________________________________________
SUBROUTINE swappointer( pointer1, pointer2)
REAL(kind=db), DIMENSION(:), POINTER, INTENT(inout):: pointer1, pointer2
REAL(kind=db), DIMENSION(:), POINTER:: temppointer
temppointer=>pointer1
pointer1=>pointer2
pointer2=>temppointer
END SUBROUTINE swappointer
!_______________________________________________________________________________
SUBROUTINE loaduniformRZ(p, VR,VZ,VTHET)
USE basic, ONLY: plasmadim, rnorm, temp, qsim, msim
USE constants, ONLY: me, kb, elchar
REAL(kind=db), INTENT(inout) ::VZ(:), VR(:), VTHET(:)
TYPE(particles), INTENT(INOUT):: p
CALL creat_parts(p, size(VR,1))
p%Nploc=size(VR,1)
p%Nptot=size(VR,1)
p%q=sign(elchar,qsim)
p%weight=msim/me
p%m=me
p%qmRatio=qsim/msim
! Initial distribution in z with normalisation
CALL loduni(1,p%Z(1:p%Nploc))
p%Z(1:p%Nploc)=(plasmadim(1)+(plasmadim(2)-plasmadim(1))*p%Z(1:p%Nploc))/rnorm
! Initial distribution in r with normalisation
CALL loduni(2,p%R(1:p%Nploc))
p%R(1:p%Nploc)=(plasmadim(3)+p%R(1:p%Nploc)*(plasmadim(4)-plasmadim(3)))/rnorm
! Initial velocities distribution
CALL loadGaussianVelocities(p, VR, VZ, VTHET, temp)
END SUBROUTINE loaduniformRZ
!_______________________________________________________________________________
SUBROUTINE loadDavidson(p, VR,VZ,VTHET, lodr)
USE constants, ONLY: me, kb, elchar
USE basic, ONLY: nplasma, rnorm, plasmadim, distribtype, H0, P0, Rcurv, width, qsim, msim, &
& omegac, zgrid, nz, rnorm, n0, nblock, temp
interface
subroutine lodr(nbase,y,rminus,rplus)
USE constants
REAL(kind=db), INTENT(out) :: y(:)
INTEGER, INTENT(in) :: nbase
REAL(kind=db), INTENT(in) :: rplus, rminus
end subroutine
end interface
TYPE(particles), INTENT(INOUT):: p
REAL(kind=db), INTENT(INOUT)::VZ(:), VR(:), VTHET(:)
REAL(kind=db), DIMENSION(:), ALLOCATABLE::ra, rb, z
REAL(kind=db) :: r0, deltar2, halfLz, Mirrorratio, Le, VOL
INTEGER :: j, n, blockstart, blockend, addedpart, remainparts
INTEGER, DIMENSION(:), ALLOCATABLE :: blocksize
CALL creat_parts(p, size(VR,1))
p%Nploc=size(VR,1)
p%Nptot=p%Nploc
Allocate(ra(nblock),rb(nblock), z(0: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)
z(0)=plasmadim(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)
z(n)=z(0)+n*(plasmadim(2)-plasmadim(1))/nblock
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*MINVAL(ra)*(rb-ra)*(plasmadim(2)-plasmadim(1))/nblock)
qsim=VOL*n0*elchar/nplasma
msim=abs(qsim)/elchar*me
p%weight=abs(qsim)/elchar
p%m=me
p%q=sign(elchar,qsim)
p%qmRatio=p%q/p%m
blockstart=1
blockend=0
ALLOCATE(blocksize(nblock))
WRITE(*,*) "blocksize: ", size(blocksize), nblock
DO n=1,nblock
blocksize(n)=nplasma/VOL*2*pi*MINVAL(ra)*(rb(n)-ra(n))*(plasmadim(2)-plasmadim(1))/nblock
END DO
remainparts=p%Nploc-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
CALL loadPartSlices(p, lodr, ra, rb, z, blocksize)
IF(distribtype .eq. 5) THEN
CALL loadGaussianVelocities(p, VR, VZ, VTHET, temp)
VZ=VZ/4
VR=VR*8
VTHET=VTHET*8
ELSE
Call loadDavidsonVelocities(p, VR, VZ, VTHET, H0, P0)
END IF
END SUBROUTINE loadDavidson
SUBROUTINE loadDavidsonVelocities(p, VR,VZ,VTHET, H0, P0)
USE constants, ONLY: me, kb, elchar
USE basic, ONLY: rnorm, Rcurv, B0, width, vnorm, zgrid, nz
TYPE(particles), INTENT(INOUT):: p
REAL(kind=db), INTENT(INOUT)::VZ(:), VR(:), VTHET(:)
REAL(kind=db), INTENT(IN):: H0, P0
REAL(kind=db) :: athetpos, rg, zg, halfLz, Mirrorratio, Pcomp, Acomp
INTEGER :: i
MirrorRatio=(Rcurv-1)/(Rcurv+1)
halfLz=(zgrid(nz)+zgrid(0))/2
! Load velocities theta velocity
! Loading of r and z velocity is done in adapt_vinit to have
! access to parts%pot
DO i=1,p%Nploc
! Interpolation for Magnetic potential
rg=p%R(i)*rnorm
zg=(p%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/p%m
Acomp=-p%qmRatio*Athetpos
VTHET(i)=SIGN(MIN(abs(Pcomp+Acomp),sqrt(2*H0/p%m)),Pcomp+Acomp)
!VTHET(i)=Pcomp+Acomp
END DO
VTHET=VTHET/vnorm
VZ=0._db
VR=0._db
p%Davidson=.true.
p%H0=H0
p%P0=P0
END SUBROUTINE loadDavidsonvelocities
SUBROUTINE loadGaussianVelocities(p, VR,VZ,VTHET, temperature)
USE basic, ONLY: vnorm
USE constants, ONLY: kb
REAL(kind=db), INTENT(inout) ::VZ(:), VR(:), VTHET(:)
TYPE(particles), INTENT(INOUT):: p
REAL(kind=db), INTENT(IN):: temperature
REAL(kind=db):: vth
! Initial velocities distribution
vth=sqrt(kb*temperature/p%m)/vnorm !thermal velocity
CALL lodgaus(3,VZ)
CALL lodgaus(5,VR)
CALL lodgaus(7,VTHET)
VZ=VZ*vth
VR=VR*vth
VTHET=VTHET*vth
p%temperature=temperature
p%Davidson=.false.
END SUBROUTINE loadGaussianVelocities
SUBROUTINE loadPartslices(p, lodr, ra, rb, z, blocksize)
USE basic, ONLY: rnorm
interface
subroutine lodr(nbase,y,rminus,rplus)
USE constants
REAL(kind=db), INTENT(out) :: y(:)
INTEGER, INTENT(in) :: nbase
REAL(kind=db), INTENT(in) :: rplus, rminus
end subroutine
end interface
TYPE(particles), INTENT(INOUT):: p
REAL(kind=db), INTENT(IN)::ra(:), rb(:), z(0:)
INTEGER, DIMENSION(:), INTENT(IN) :: blocksize
INTEGER :: n, blockstart, blockend, nblock
nblock=size(blocksize,1)
blockstart=1
blockend=0
DO n=1,nblock
blockstart=blockend+1
blockend=MIN(blockstart+blocksize(n)-1,p%Nploc)
! Initial distribution in z with normalisation between magnetic mirrors
CALL loduni(1,p%Z(blockstart:blockend))
p%Z(blockstart:blockend)= (z(n-1)+p%Z(blockstart:blockend)*(z(n)-z(n-1)))/rnorm
CALL lodr(2,p%R(blockstart:blockend),ra(n), rb(n))
p%R(blockstart:blockend)=p%R(blockstart:blockend)/rnorm
END DO
END SUBROUTINE loadPartslices
SUBROUTINE loadPartFile(p, partfileindex, VR, VZ, VTHET)
USE basic, ONLY: partfile, nplasma, lu_partfile
implicit None
TYPE(particles), INTENT(INOUT):: p
REAL(kind=db), DIMENSION(:), ALLOCATABLE, INTENT(INOUT)::VR, VZ, VTHET
INTEGER, INTENT(IN):: partfileindex
INTEGER:: nblock = 0
REAL(kind=db), Dimension(:), ALLOCATABLE:: ra, rb, z
INTEGER, Dimension(:), ALLOCATABLE:: npartsslice
INTEGER:: velocitytype=1 !< 1) gaussian with temp 2) Davidson with H0, P0
INTEGER:: radialtype=1 !< 1) 1/R 2) uniform 3) 1/R^2 4) gauss
INTEGER:: npartsalloc !< initial size of particles arrays
REAL(kind=db):: mass=me
REAL(kind=db):: charge=-elchar
REAL(kind=db):: weight=1.0
CHARACTER(len=256) :: header=' ' !< header of csv file
REAL(kind=db):: H0=3.2e-14 !< Total energy
REAL(kind=db):: P0=8.66e-25 !< Canonical angular momentum
REAL(kind=db):: temperature=10000 !< temperature in kelvins
LOGICAL :: is_test = .false. !< Defines if particle are test particles or tracers
INTEGER:: i, ierr, openerr
NAMELIST /partsload/ nblock, mass, charge, weight, npartsalloc, velocitytype, &
& radialtype, temperature, H0, P0, is_test
OPEN(UNIT=lu_partfile,FILE=trim(partfile(partfileindex)),ACTION='READ',IOSTAT=openerr)
header=' '
IF(openerr .ne. 0) THEN
CLOSE(unit=lu_partfile)
RETURN
END IF
READ(lu_partfile,partsload)
IF(mpirank .eq.0) THEN
WRITE(*,'(a,i2,a,a)')"reading partfile: ", partfileindex, " ", partfile(partfileindex)
WRITE(*,partsload)
END IF
IF( nblock .ge. 1) THEN
ALLOCATE(z(0:nblock),ra(nblock),rb(nblock), npartsslice(nblock))
DO WHILE(header(1:8) .ne. '//slices')
READ(lu_partfile,'(a)') header
END DO
DO i=1,nblock
READ(lu_partfile,*) z(i-1),ra(i),rb(i),npartsslice(i)
END DO
READ(lu_partfile,*) z(nblock)
CALL creat_parts(p,max(npartsalloc,sum(npartsslice)))
p%Nploc=sum(npartsslice)
p%Nptot=p%Nploc
IF(partfileindex .eq. 1) nplasma=p%Nploc
IF( .not. allocated(VR)) ALLOCATE(VR(p%Nploc))
IF( .not. allocated(VZ)) ALLOCATE(VZ(p%Nploc))
IF( .not. allocated(VTHET)) ALLOCATE(VTHET(p%Nploc))
p%m=mass
p%q=charge
p%weight=weight
p%qmRatio=charge/mass
p%is_test=is_test
SELECT CASE(radialtype)
CASE(1) ! 1/R distribution in R
CALL loadPartslices(p, lodunir, ra, rb, z, npartsslice)
CASE(2) ! flat top distribution in R
CALL loadPartslices(p, lodlinr, ra, rb, z, npartsslice)
CASE(3) ! 1/R^2 distribution in R
CALL loadPartslices(p, lodinvr, ra, rb, z, npartsslice)
CASE(4) ! gaussian distribution in R
CALL loadPartslices(p, lodgausr, ra, rb, z, npartsslice)
CASE DEFAULT
IF (mpirank .eq. 0) WRITE(*,*) "Unknown type of radial distribution:", radialtype
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END SELECT
SELECT CASE(velocitytype)
CASE(1) ! Gaussian with temperature
CALL loadGaussianVelocities(p, VR, VZ, VTHET, temperature)
CASE(2)
CALL loadDavidsonVelocities(p, VR, VZ, VTHET, H0, P0)
CASE DEFAULT
IF (mpirank .eq. 0) WRITE(*,*) "Unknown type of velocity distribution:", velocitytype
CALL MPI_Abort(MPI_COMM_WORLD, -1, ierr)
END SELECT
END IF
CLOSE(unit=lu_partfile)
END SUBROUTINE
!===============================================================================
SUBROUTINE Temp_rescale
! USE basic, ONLY: temprescale, nlclassical, nz
! INTEGER:: i, gridindex
! REAL(kind=db) :: 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
!---------------------------------------------------------------------------
!> @author
!> Guillaume Le Bars EPFL/SPC
!
! DESCRIPTION:
!>
!> @brief Increase the number of macroparticles by separating each previous macroparticles into
!> samplefactor new macroparticles of equally divided weight. The new sub particles are distributed
!> uniformly in space to maintain the density and other moments.
!
!> @param [in] samplefactor multiplicator of the number of macroparticles.
!> @param [in] p particles type to increase.
!---------------------------------------------------------------------------
SUBROUTINE upsample(p, samplefactor)
USE basic, ONLY : nplasma, dr, dz
INTEGER, INTENT(IN) ::samplefactor
TYPE(particles), INTENT(INOUT):: p
INTEGER:: i, j, currentindex
REAL(kind=db), DIMENSION(p%Nploc) :: spreaddir ! random direction for the spread of each initial macro particle
REAL(kind=db) :: dir ! Direction in which the particle is moved
REAL(kind=db) :: 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,p%Nploc
DO j=1,samplefactor-1
currentindex=p%Nploc+(i-1)*(samplefactor-1)+j
CALL move_part(p,i,currentindex)
p%partindex(currentindex)=currentindex
dir = spreaddir(i)+2*pi*j/samplefactor
p%R(currentindex)=p%R(currentindex) + dl*cos(dir)
p%Z(currentindex)=p%Z(currentindex) + dl*sin(dir)
END DO
p%partindex(i)=i
p%R(i)=p%R(i) + dl*cos(spreaddir(i))
p%Z(i)=p%Z(i) + dl*sin(spreaddir(i))
END DO
nplasma=nplasma*samplefactor
p%weight=p%weight/samplefactor
p%Nploc=p%Nploc*samplefactor
END SUBROUTINE upsample
END MODULE beam
c4science · Help